Excel sayfa Birleştir

[ayagiz44]

Aylar Klasör içerisinde yaklaşık (50) adet excel var
Tüm excel birbirinin kopyası sadece içerik farklı excel açıldığında UserForm5 açılıyor bendeki formatta kullanım için açıklama var
Açılan sayfa adı (VERİ) sadece bu sayfanın $B8:$AL508 aralığında dolu olan satırları birleştirecek
Bu arada sayfa korumalı
Sayfa Koruma Alt+F8 KorumaP
Korumalı sayfadan alıp birleştirecek

http://www.dosya.tc/server9/gztzb5/D...estir.rar.html

 

[Asri]

Bu konu genel kullanım için, tüm excel dosyalarında belirli bir sayfanın belirli bir alanını tek sayfada birleştirir.

Kendi kullanımınıza göre düzenleyebilir siniz. VBA ve koruma şifresi yoktur.

http://www.excel.web.tr/f52/tum-excel-sayfalary-tek-sayfada-belirli-sayfa-ve-t165402.html#post901394

 

[ayagiz44]

Teşekkürler

kısmen işimi görüyor al508 kesmiyor alt kısmıda kopyalıyor
Selamlar.

 

[Asri]

Bu kod dosyanıza dahil edildi.

VBA şifreli olduğu için dosyayı özelde gönderiyorum.

Ayarlar sayfasında doyaların yolu, veri alınacak sayfa, veri alınacak aralık ve sonsatır tespiti için kolon adı C olabilir.
Bu bilgileri girdikten sonra VERİ sayfasında Birleştir butonuna tıklayın.

Dim sayfaadi, eskidosya, satirkolonu, yenidosya, alan As String
Dim aradizin, dosyaadi, dosyaadi2 As String
Dim say As Integer
Dim enfazla, gelensonsatir, icmalsonsatir As Long
Dim icmaldosya As String


Sub menu()
    icmaldosya = ActiveWorkbook.Name
    Set shayar = Sheets("Ayarlar")
    aradizin = shayar.Cells(2, 1).Value & "\"
    sayfaadi = shayar.Cells(2, 2).Value
    enfazla = shayar.Cells(2, 3).Value
    alan = shayar.Cells(2, 4).Value
    satirkolonu = shayar.Cells(2, 5).Value
    Call alanbelirle
    Sheets("VERİ").Select
    sonsatir1 = Cells(Rows.Count, "C").End(3).Row
    If sonsatir1 = 6 Then sonsatir1 = 8
    yenialan = alan & sonsatir1
    KorumaP
    Range(yenialan).ClearContents
    icmalsonsatir = 8
    
    say = 0
    Call dosyalaribul(aradizin)
    
    Cells.Select
    Range("A1").Activate
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Koruma
    MsgBox ("Sayfa birleştirme işlemi tamamlandı.")
End Sub

Sub alanbelirle()
    For i = Len(alan) To 1 Step -1
      harf = Mid(alan, i, 1)
      If sadecesayimi(harf) = False Then
         alan = Mid(alan, 1, i)
         Exit For
      End If
    Next i
End Sub

Private Sub dosyalaribul(folderPath)
    Dim Folder As Scripting.Folder, Subfolder As Scripting.Folder, File As Scripting.File
    Dim wb As Workbook
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(folderPath)
    
    If Folder.subfolders.Count > 0 Then
      For Each Subfolder In Folder.subfolders
        For Each File In Subfolder.Files
          dosyaadi = File.Path
          dosyaadi2 = File.Name
          Call Exceldeara
        Next
      Next
     Else
        For Each File In Folder.Files
          dosyaadi = File.Path
          dosyaadi2 = File.Name
          Call Exceldeara
        Next
     End If
End Sub

Sub Exceldeara()
    
    If Mid(dosyaadi2, InStrRev(dosyaadi2, ".")) Like ".xls*" Then
        Workbooks.Open Filename:=dosyaadi, UpdateLinks:=0
        eskidosya = ActiveWorkbook.Name
        say = say + 1
        Call Sayfa_Birlestir
        Windows(eskidosya).Close
    End If
End Sub

Private Function SheetExists(sname) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function


Sub deneme()

End Sub


Sub Sayfa_Birlestir()
   Application.DisplayAlerts = False
   
    If SheetExists(sayfaadi) = False Then Exit Sub
    
    Sheets(sayfaadi).Select
    Cells(1, 1).Select
    ilksonsatir = icmalsonsatir
        
     If ilksonsatir > enfazla Then
      MsgBox ("Veriler " & enfazla & " satır sayısını geçti. Aktarım tamamlanamadı.")
      GoTo atla
    End If
    
    gelensonsatir = Cells(Rows.Count, "C").End(3).Row
    For i = 8 To gelensonsatir
      gec = Cells(i, 3).Value
      If gec = "" Then Exit For
    Next i
    gelensonsatir = i - 1
   
    yenialan = alan & gelensonsatir
    Range(yenialan).Select
    Selection.Copy
    Workbooks(icmaldosya).Activate
        
    If icmalsonsatir > 8 Then icmalsonsatir = icmalsonsatir + 1
    
    If ilksonsatir + gelensonsatir > enfazla Then
      GoTo atla
    End If

    Range("B" & icmalsonsatir).Select
    ActiveSheet.Paste
    Cells(1, 1).Select
    icmalsonsatir = icmalsonsatir + gelensonsatir - 8
    Windows(eskidosya).Activate
    Cells(1, 1).Select
    
atla:

  Application.DisplayAlerts = False
  
End Sub

Function sadecesayimi(sadecesayistr)
  liste = "0123456789"
  For k = 1 To Len(sadecesayistr)
    harf = Mid(sadecesayistr, k, 1)
    If InStr(liste, harf) = 0 Then
       sadecesayimi = False
       Exit Function
    End If
  Next k
  sadecesayimi = True
End Function

 

[ayagiz44]

Çok Teşekkür ederim
Emeğine sağlık selamlar.