Farklı Excel Çalışma Sayfalarını Tek Sayfa da birleştirmek

[SeviLmeyen]

Selamlar Bilgisayarımda içerikleri başlıkları şekilleri şemalleri aynı 5 Farklı Excel çalışma sayfası var. Bunları tek excelde belirttiğim sıralamada örneğin ilk A çalışma kitabı sonra B sonra C boş Excel çalışma kitabımıza alt alta satır oluşturacak şekilde. Örneğin A çalışma kitabında toplam satır sayısı 3000 B de 5000 ilk önce A yı yazdırıp 3001 den B yi başlatım 8002 den C yi başlatabilirmiyiz öyle bir kod falan var mıdır?
Saygılarımla.

 

[metin_0606]

Selamlar Bilgisayarımda içerikleri başlıkları şekilleri şemalleri aynı 5 Farklı Excel çalışma sayfası var. Bunları tek excelde belirttiğim sıralamada örneğin ilk A çalışma kitabı sonra B sonra C boş Excel çalışma kitabımıza alt alta satır oluşturacak şekilde. Örneğin A çalışma kitabında toplam satır sayısı 3000 B de 5000 ilk önce A yı yazdırıp 3001 den B yi başlatım 8002 den C yi başlatabilirmiyiz öyle bir kod falan var mıdır?
Saygılarımla.

Bu çalışma sayfaları tek bir çalışma kitabının mı içinde

 

[SeviLmeyen]

Bu çalışma sayfaları tek bir çalışma kitabının mı içinde

Hepsi Farklı çalışma kitabı. Ben hepsini tek bir kitapta birleştirmek istiyorum varsa öyle bir yolu

 

[metin_0606]

Hepsi Farklı çalışma kitabı. Ben hepsini tek bir kitapta birleştirmek istiyorum varsa öyle bir yolu

Örnek Çalışmada deneyiniz

Sub birleştir()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
 
Set WS = Sheets.Add
 
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myfolder = .SelectedItems(1) & "\"
End With
chk = 0
Value = Dir(myfolder)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
            Else
                On Error GoTo 0
                For Each sht In ActiveWorkbook.Worksheets
                    If sht.Range("A1") <> "" Then
                        Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
                        If chk = 0 Then
                            sht.Range("A1").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow)
                            chk = 1
                        Else
                            Set crng = sht.Range("A1").CurrentRegion
                            Set crng = crng.Offset(1, 0)
                            Set crng = crng.Resize(crng.Rows.Count - 1)
                            crng.Copy Destination:=WS.Range("A" & Lrow)
                        End If
                    End If
                Next sht
            End If
            Workbooks(Value).Close False
            On Error GoTo 0
        End If
    End If
    Value = Dir
Loop
Cells.EntireColumn.AutoFit
End Sub

 

[usubaykan]

Alternatif,
Bulunduğu klasördeki tüm dosyaların sayfalarını kontrol eder dolu olanı ham_data sayfasının "B" sütunundan itibaren kopyalar.
A sütuna hangi dosyanın hangi sayfasını aldığını yazar.

Option Explicit
Public Kontrol
Public Sayfa_Adi
Public Baglanti
Public Kayit_Seti
Public Excel
Public Dosya
Public S1
Public S2
Public Son
Public Son1
Public Dosyalar
Public Klasör
Public Katalog
Public Data
Public Tablo
Public Say

Sub Dış_Veri_Al()
Application.ScreenUpdating = False
Dosya = ThisWorkbook.Path & "\"
Set Dosyalar = CreateObject("Scripting.filesystemobject")
Set Klasör = Dosyalar.getfolder("" & Dosya & "")

Set S2 = Sheets("Ham_Data")
S2.Cells.Clear

For Each Dosyalar In Klasör.Files
Excel = Dosya & Dosyalar.Name
Range("G1") = Dosyalar.Name
Say = WorksheetFunction.CountIf(Range("G1"), "*~$*")
Range("G1").Clear
If Say = 0 Then
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Excel & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
Son1 = Replace(Tablo.Name, "'", "")
If Right(Son1, 1) <> "_" Then
If Right(Son1, 1) = "$" Then
Sayfa_Adi = Left$(Son1, Len(Son1) - 1)
End If
End If

Set Data = Nothing
Set Katalog = Nothing

    
    Dosya = ThisWorkbook.Path & "\"
    
    If Dosyalar.Name <> ThisWorkbook.Name Then
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
   
   Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Excel & _
    ";Extended Properties=""Excel 12.0;Hdr=no;imex=1"";"
    Kayit_Seti.Open "Select * From [" & Sayfa_Adi & "$]", Baglanti, 1, 1
    Son = Cells(Rows.Count, "B").End(3).Row + 1
    Son1 = Cells(Rows.Count, "A").End(3).Row
    If Kayit_Seti(0) > 0 Then
    With S2
        .Cells(.Rows.Count, 1).End(3)(Son + 1 - Son1, 2).CopyFromRecordset Kayit_Seti
        Son1 = Cells(Rows.Count, "B").End(3).Row
        Range("A" & Son & ":A" & Son1) = Dosyalar.Name & " (" & Sayfa_Adi & ")"
    End With
    End If
   
    Kayit_Seti.Close
    Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    End If
    End If
    Next
End If
Next
MsgBox "Ok"
End Sub

 

[SeviLmeyen]

Usubaykan çok teşekkür ediyorum en Kısa zamanda deneyeceğim.

 

[ahmeduafi]

Alternatif,
Bulunduğu klasördeki tüm dosyaların sayfalarını kontrol eder dolu olanı ham_data sayfasının "B" sütunundan itibaren kopyalar.
A sütuna hangi dosyanın hangi sayfasını aldığını yazar.

Option Explicit
Public Kontrol
Public Sayfa_Adi
Public Baglanti
Public Kayit_Seti
Public Excel
Public Dosya
Public S1
Public S2
Public Son
Public Son1
Public Dosyalar
Public Klasör
Public Katalog
Public Data
Public Tablo
Public Say

Sub Dış_Veri_Al()
Application.ScreenUpdating = False
Dosya = ThisWorkbook.Path & "\"
Set Dosyalar = CreateObject("Scripting.filesystemobject")
Set Klasör = Dosyalar.getfolder("" & Dosya & "")

Set S2 = Sheets("Ham_Data")
S2.Cells.Clear

For Each Dosyalar In Klasör.Files
Excel = Dosya & Dosyalar.Name
Range("G1") = Dosyalar.Name
Say = WorksheetFunction.CountIf(Range("G1"), "*~$*")
Range("G1").Clear
If Say = 0 Then
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Excel & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
Son1 = Replace(Tablo.Name, "'", "")
If Right(Son1, 1) <> "_" Then
If Right(Son1, 1) = "$" Then
Sayfa_Adi = Left$(Son1, Len(Son1) - 1)
End If
End If

Set Data = Nothing
Set Katalog = Nothing

   
    Dosya = ThisWorkbook.Path & "\"
   
    If Dosyalar.Name <> ThisWorkbook.Name Then
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
  
   Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Excel & _
    ";Extended Properties=""Excel 12.0;Hdr=no;imex=1"";"
    Kayit_Seti.Open "Select * From [" & Sayfa_Adi & "$]", Baglanti, 1, 1
    Son = Cells(Rows.Count, "B").End(3).Row + 1
    Son1 = Cells(Rows.Count, "A").End(3).Row
    If Kayit_Seti(0) > 0 Then
    With S2
        .Cells(.Rows.Count, 1).End(3)(Son + 1 - Son1, 2).CopyFromRecordset Kayit_Seti
        Son1 = Cells(Rows.Count, "B").End(3).Row
        Range("A" & Son & ":A" & Son1) = Dosyalar.Name & " (" & Sayfa_Adi & ")"
    End With
    End If
  
    Kayit_Seti.Close
    Baglanti.Close
  
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    End If
    End If
    Next
End If
Next
MsgBox "Ok"
End Sub

Bu konu eski biraz ama bu kod ile veri çektiğimde ikinci sayfayı 4 kez ard arda kopyalamış oluyor neden yaptığını anlıyamadım yardımcı olabilirmisiniz. şimdiden tşk.ler

 

[Korhan Ayhan]

Denediğiniz dosyaları paylaşabilirmisiniz.