Aynı olan değerlerden yeni çalışma kitabi oluşturma

Astalavista58 · 24 Mart 2022

Merhabalar öncelikler hayırlı günleriniz olsun. Ben "E" sütununda il isimleri aynı olan verileri başlıkla birlikte yeni bir çalışma kitabına kopyalayarak, masaüstünde oluşturulacak yeni klasöre kaydetmek istiyorum. Yardımcı olabilir misiniz

EmrExcel16 · 24 Mart 2022

Merhaba , aşağıdaki konu üzerinden verdiğim kodlar üzerinden ilerleyerek , biraz uğraşla kendinizin bunu yapabileceğine inanıyorum , ögrenmeniz açısından da adım olur sizin için..

İsme göre yeni çalışma kitabı oluşturmak

Herkese merhabalar, küçük bir talebim olacaktı. Ekteki dosyada Sayfa1’i, Sayfa2’de “A” sütununda yazan isimlerle masaüstünde yeni bir klasör oluşturarak kaydetmek istiyorum. Yardımcı olabilirseniz çok mutlu olurum

www.excel.web.tr

Astalavista58 · 24 Mart 2022

EmrExcel16' Alıntı:
Merhaba , aşağıdaki konu üzerinden verdiğim kodlar üzerinden ilerleyerek , biraz uğraşla kendinizin bunu yapabileceğine inanıyorum , ögrenmeniz açısından da adım olur sizin için..

İsme göre yeni çalışma kitabı oluşturmak

Herkese merhabalar, küçük bir talebim olacaktı. Ekteki dosyada Sayfa1’i, Sayfa2’de “A” sütununda yazan isimlerle masaüstünde yeni bir klasör oluşturarak kaydetmek istiyorum. Yardımcı olabilirseniz çok mutlu olurum

www.excel.web.tr

Nasıl bir yol izleyeceğimi bilemedim. Ama uğraşacağm, çok teşekkür ederim ilginiz için

Haluk · 24 Mart 2022

ADO ile yapılan alternatif aşağıda verilmiştir....

Dosyalar, masaüstünde oluşturulacak "RAPORLAR" isimli klasörün içinde oluşturulacaktır.

C#:

Sub Main()
'   Haluk - 24/03/2022
'   sa4truss@gmail.com
    Dim adoCN As Object, RS As Object
    Dim myFolder As String, strSQL As String
   
    Const adOpenKeyset = 1
   
    myFolder = Environ("USERPROFILE") & "\Desktop\" & "RAPORLAR"
   
    If Dir(myFolder, vbDirectory) = "" Then MkDir myFolder
   
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=Yes; IMEX=1"
    adoCN.Open
   
    strSQL = "Select Distinct [İL] from [Sayfa1$]"
   
    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN
   
    Do Until RS.EOF
        CreateFile RS(0), myFolder
        RS.MoveNext
    Loop
   
    MsgBox "Dosyalar oluşturuldu !", vbInformation
   
    RS.Close
    adoCN.Close
    Set RS = Nothing
    Set adoCN = Nothing
End Sub
'
Sub CreateFile(fileName As String, folderName As String)
'   Haluk - 24/03/2022
'   sa4truss@gmail.com
    Dim objConn As Object, strArgs As String, strSQL As String
   
    Set objConn = CreateObject("ADODB.Connection")
   
    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
              "Readonly=True; DBQ=" & folderName & "\" & fileName & ".xlsb"
   
    objConn.Open strArgs
   
    strSQL = "Create Table Rapor (ADI Varchar(10), SOYADI Varchar(20), " & _
                    "CİNSİYET Varchar(1), YAŞ Integer, İL Varchar(20))"
   
    objConn.Execute strSQL
   
    strSQL = "Insert Into [Rapor$] ([ADI], [SOYADI], [CİNSİYET], [YAŞ], [İL]) " & _
             "Select [ADI], [SOYADI], [CİNSİYET], [YAŞ], [İL] From [Sayfa1$] " & _
             "In '' [Excel 12.0;Database=" & ThisWorkbook.FullName & "] Where [İL]= '" & fileName & "'"
   
    objConn.Execute strSQL
   
    objConn.Close
   
    Set objConn = Nothing
End Sub

.

Astalavista58 · 24 Mart 2022

Haluk Bey, elinize sağlık çok teşekkür ediyorum çok güzel çalışıyor. Hayırlı geceler dilerim..

EmrExcel16 · 25 Mart 2022

Astalavista58' Alıntı:
Nasıl bir yol izleyeceğimi bilemedim. Ama uğraşacağm, çok teşekkür ederim ilginiz için

Aşağıdaki gibi yapılabilir..

Kod:

Sub Farkli_Kaydet()
    Dim DsyYol, i
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    On Error Resume Next
    DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Emr"
    If Dir(DsyYol, vbDirectory) = "" Then MkDir (DsyYol)
   
    For i = 2 To Cells(Rows.Count, 5).End(3).Row
   
        If Cells(i, 5).Value <> "" And WorksheetFunction.CountIf(Range([E2], Cells(i, 5)), Cells(i, 5)) <= 1 Then
            Sheets("Sayfa1").Copy
            Range("A1:E" & Cells(Rows.Count, 5).End(3).Row).AutoFilter Field:=5, Criteria1:="<>" & Cells(i, 5)
            Range("A2:E" & Cells(Rows.Count, 5).End(3).Row).SpecialCells(xlCellTypeVisible).Delete
            ActiveSheet.AutoFilterMode = False
            ActiveWorkbook.SaveAs DsyYol & "\" & ThisWorkbook.Sheets("Sayfa1").Cells(i, 5).Value
            ActiveWorkbook.Close SaveChanges:=False
        End If
     
    Next
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True 
    MsgBox "islem tamam..."
 
End Sub

Astalavista58 · 25 Mart 2022

EmrExcel16' Alıntı:

Aşağıdaki gibi yapılabilir..

Kod:

Sub Farkli_Kaydet()
    Dim DsyYol, i
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
    DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Emr"
    If Dir(DsyYol, vbDirectory) = "" Then MkDir (DsyYol)
  
    For i = 2 To Cells(Rows.Count, 5).End(3).Row
  
        If Cells(i, 5).Value <> "" And WorksheetFunction.CountIf(Range([E2], Cells(i, 5)), Cells(i, 5)) <= 1 Then
            Sheets("Sayfa1").Copy
            Range("A1:E" & Cells(Rows.Count, 5).End(3).Row).AutoFilter Field:=5, Criteria1:="<>" & Cells(i, 5)
            Range("A2:E" & Cells(Rows.Count, 5).End(3).Row).SpecialCells(xlCellTypeVisible).Delete
            ActiveSheet.AutoFilterMode = False
            ActiveWorkbook.SaveAs DsyYol & "\" & ThisWorkbook.Sheets("Sayfa1").Cells(i, 5).Value
            ActiveWorkbook.Close SaveChanges:=False
        End If
    
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "islem tamam..."

End Sub

Merhabalar öncelikle günaydın Sayın EmrExcel16, denedim ancak sadece Kayseri isminde bir dosya oluşturuyor , dosyayı açınca içinde tüm veriler var

EmrExcel16 · 25 Mart 2022

Merhaba , birde bu şekilde deneyin..

Kod:

Sub Farkli_Kaydet()
    Dim DsyYol, i
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
    DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Emr"
    If Dir(DsyYol, vbDirectory) = "" Then MkDir (DsyYol)
  
    Set Syf = ThisWorkbook.Sheets("Sayfa1")  
    For i = 2 To Syf.Cells(Rows.Count, 5).End(3).Row
  
        If Syf.Cells(i, 5).Value <> "" And WorksheetFunction.CountIf(Syf.Range([E2], Syf.Cells(i, 5)), Syf.Cells(i, 5)) <= 1 Then
            Sheets("Sayfa1").Copy          
            ActiveSheet.Range("A1:E" & ActiveSheet.Cells(Rows.Count, 5).End(3).Row).AutoFilter Field:=5, Criteria1:="<>" & Syf.Cells(i, 5)
            ActiveSheet.Range("A2:E" & ActiveSheet.Cells(Rows.Count, 5).End(3).Row).SpecialCells(xlCellTypeVisible).Delete
            ActiveSheet.AutoFilterMode = False
            ActiveWorkbook.SaveAs DsyYol & "\" & Syf.Cells(i, 5).Value
            ActiveWorkbook.Close SaveChanges:=False
        End If
    
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "islem tamam..."
End Sub

Astalavista58 · 25 Mart 2022

Sayın EmrExcel16 gerçekten çok çok teşekkür ederim işimi öyle kolaylaştırdı ki, Allah razı olsun hayırlı cumalariniz olsun

dost · 27 Aralık 2023

Haluk' Alıntı:

ADO ile yapılan alternatif aşağıda verilmiştir....

Dosyalar, masaüstünde oluşturulacak "RAPORLAR" isimli klasörün içinde oluşturulacaktır.

C#:

Sub Main()
'   Haluk - 24/03/2022
'   sa4truss@gmail.com
    Dim adoCN As Object, RS As Object
    Dim myFolder As String, strSQL As String
  
    Const adOpenKeyset = 1
  
    myFolder = Environ("USERPROFILE") & "\Desktop\" & "RAPORLAR"
  
    If Dir(myFolder, vbDirectory) = "" Then MkDir myFolder
  
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
  
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=Yes; IMEX=1"
    adoCN.Open
  
    strSQL = "Select Distinct [İL] from [Sayfa1$]"
  
    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN
  
    Do Until RS.EOF
        CreateFile RS(0), myFolder
        RS.MoveNext
    Loop
  
    MsgBox "Dosyalar oluşturuldu !", vbInformation
  
    RS.Close
    adoCN.Close
    Set RS = Nothing
    Set adoCN = Nothing
End Sub
'
Sub CreateFile(fileName As String, folderName As String)
'   Haluk - 24/03/2022
'   sa4truss@gmail.com
    Dim objConn As Object, strArgs As String, strSQL As String
  
    Set objConn = CreateObject("ADODB.Connection")
  
    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
              "Readonly=True; DBQ=" & folderName & "\" & fileName & ".xlsb"
  
    objConn.Open strArgs
  
    strSQL = "Create Table Rapor (ADI Varchar(10), SOYADI Varchar(20), " & _
                    "CİNSİYET Varchar(1), YAŞ Integer, İL Varchar(20))"
  
    objConn.Execute strSQL
  
    strSQL = "Insert Into [Rapor$] ([ADI], [SOYADI], [CİNSİYET], [YAŞ], [İL]) " & _
             "Select [ADI], [SOYADI], [CİNSİYET], [YAŞ], [İL] From [Sayfa1$] " & _
             "In '' [Excel 12.0;Database=" & ThisWorkbook.FullName & "] Where [İL]= '" & fileName & "'"
  
    objConn.Execute strSQL
  
    objConn.Close
  
    Set objConn = Nothing
End Sub

.

@Haluk merhaba,

Yukarıdaki kodu kullanıyorum.

Yaratılacak dosya sayısı fazla olduğunda, belli bir dosyayı oluşturduktan sonra aşağıdaki hatayı alıyorum.

Bu hatayı nasıl geçebilirim?

dost · 27 Aralık 2023

Merhaba,

Her dosya oluştururken;

C++:

Application.Wait (Now + TimeValue("0:00:03"))

yaptığımda hata almadım. Ancak çözüm müdür?

Haluk · 27 Aralık 2023

Örneğin, her 10 dosyada bir Wait komutunu çalıştırabilirsiniz....

.

dost · 27 Aralık 2023

Merhaba,

C++:

If i Mod 10 = 0 Then Application.Wait (Now + TimeValue("0:00:03"))

yaptığımda aynı hatayı alıyorum. Hata verdiğinde klasörde oluşturulan dosya sayısı: 61

Galiba bir dk içerisinde gönderilen istek sayısına bakıyor gibi.

Haluk · 27 Aralık 2023

Muhtemelen bilgisayarın RAM'i ile ilgili bir durumdur.....

.

Aynı olan değerlerden yeni çalışma kitabi oluşturma

Astalavista58

Ekli dosyalar

EmrExcel16

Destek Ekibi

İsme göre yeni çalışma kitabı oluşturmak

Astalavista58

İsme göre yeni çalışma kitabı oluşturmak

Haluk

Özel Üye

Astalavista58

EmrExcel16

Destek Ekibi

Astalavista58

EmrExcel16

Destek Ekibi

Ekli dosyalar

Astalavista58

dost

Ekli dosyalar

dost

Haluk

Özel Üye

dost

Haluk

Özel Üye