Excel dosyalarını tek sayfada birleştirme

[buggsbunny]

Herkese merhaba. Birden fazla excel dosyasını tek sayfada birleştirmek istiyorum. Aşağıdaki Makrom var ancak onu kullanabilmem için gelen exceldeki sekme adının 'Sayfa1' olması gerekiyor. Ancak gönderenler bazen değiştiriyor ve gözümden kaçabiliyor. Aşağıdaki makroyu sayfa adından bağımsız bırakabilir miyiz? dosyadaki ilk sekmeye hatta tüm sekmelere baksın. zaten makro tablomdaki başlıklara göre veri getiriyor. başlıklar tutmazsa veriyi getirmiyor.

Sub KitaplariBirlestirBS()

Dim vaFiles As Variant
Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Sayın " & Environ("UserName")

ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    ws.Range("A2:g" & Rows.Count).Clear
    
    lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
    Title:="Select Files to Proceed", MultiSelect:=True)
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If
            
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
            
            Set wsa = ActiveWorkbook.ActiveSheet
            
            lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row
            lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column
            
            For c = 1 To lc
                For ca = 1 To lrc
                    If wsa.Cells(1, ca) = ws.Cells(1, c) Then
                        cn = ca
                        Exit For
                    End If
                Next ca
                For r = 2 To lra
                    y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row
                    If c <> lc Then
                        ws.Cells(y, c) = wsa.Cells(r, cn)
                    Else
                        ws.Cells(y, c) = Mid(ActiveWorkbook.Name, 1, InStr(1, _
                        ActiveWorkbook.Name, ".xls") - 1)
                    End If
                    y = y + 1
                Next r
            Next c
            wbkToCopy.Close savechanges:=False
skipfile:
        Next i
        ws.Range("A1:g1").EntireColumn.AutoFit
        ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
    Else
        ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
    End If
Else
    ms2 = MsgBox("İşlemi İptal Ettiniz", vbInformation, un)
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

 

[buggsbunny]

zaten sayfa adından bağımsızmış skıntı yok

 

[kanarya_83]

zaten sayfa adından bağımsızmış skıntı yok

Bana da bu tip birşey lazım. yardımcı olma imkanınız var mı?

 

[ahmeduafi]

Set wsa = ActiveWorkbook.ActiveSheet

bunla aktif sayfadan çekiyor benimde veri aldığım excellerde 2 sayfa var bütün sayfaları sorgulama yapacak döngü nasıl yapabiliriz

 

[ahmeduafi]

Option Explicit
Dim seper  As String
Sub ImportDataFromMultipleWorkbooks()

Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet
Dim rng As Range
Dim cll As Range
Dim ms1 As Integer
Dim c As Long
Dim lr, lc, lra, lrc, i, j, d, fRow, cIndex As Long
Dim un As String
Dim fHeader As Boolean
Dim vaFiles As Variant

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Dear " & Environ("UserName"): seper = "~"

ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    If ActiveWindow.WindowState <> xlMaximized Then ActiveWindow.WindowState = xlMaximized
    ws.UsedRange.Offset(1, 0).Clear
    
    ChDir (Environ("USERPROFILE") & Application.PathSeparator & "Desktop")
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
    Title:="Select Files to Proceed", MultiSelect:=True)
    
    On Error GoTo errPlace
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    lc = FindRowColumn(ws, "c")
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                MsgBox "Cannot Open Itself", vbExclamation, un
                GoTo skipfile:
            End If
            
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
            Set wsa = ActiveWorkbook.ActiveSheet
            
            lra = FindRowColumn(wsa, "r")
            lrc = FindRowColumn(wsa, "c")
            
            For c = 1 To lc
                fHeader = False: cIndex = 0: fRow = fAvaRow(ws, c, FindRowColumn(ws, "c"))
                For Each cll In wsa.UsedRange.Cells
                    If CleanHeading(cll.Value) = CleanHeading(ws.Cells(1, c)) Then
                        cIndex = cll.Column
                        fHeader = True
                        Exit For
                    End If
                Next cll
                If fHeader = True Then
                    With wsa
                        .Range(.Cells(cll.Offset(1, 0).Row, cIndex), _
                        .Cells(lra, cIndex)).Copy ws.Cells(fRow, c)
                    End With
                    ws.Cells(1, c) = ws.Cells(1, c) & seper
                End If
            Next c
            With ws
                On Error GoTo 0
                If .Cells(1, lc) <> "Dosya Ismi" Then .Cells(1, lc).Offset(0, 1) = _
                "Dosya Ismi": lc = FindRowColumn(ws, "c")
                If CheckDataImport(ws) = False Then
                    .Range("A" & FindRowColumn(ws, "r")).Offset(1, 0).Resize(1, lc) = _
                    "Dosyada Eslesen Hic Data Bulunamadi"
                    .UsedRange.Cells(.UsedRange.Cells.Count) = wsa.Parent.FullName
                    wsa.Parent.Close False
                    GoTo skipfile
                End If
                .UsedRange.Resize(, 1).Offset(, lc - 1).SpecialCells(xlCellTypeBlanks) = _
                wbkToCopy.FullName: lr = FindRowColumn(ws, "r")
                For j = 1 To lc
                    Set rng = .Range(.Cells(fRow, j), .Cells(lr, j))
                    If Application.CountA(rng) = 0 And _
                    Right(.Cells(1, j), Len(seper)) <> seper Then
                        rng.Value = "Bulunamadi"
                    Else
                        If Right(.Cells(1, j), Len(seper)) = seper Then .Cells(1, j) = _
                        Left(.Cells(1, j), Len(.Cells(1, j)) - Len(seper))
                    End If
                Next j
                .UsedRange.EntireColumn.AutoFit
                With .Parent.Parent
                    .StatusBar = "-->> " & wbkToCopy.Name & " Aktarildi"
                    .Wait Now + TimeValue("00:00:01")
                End With
            End With
            wbkToCopy.Close False
skipfile:
        Next i
        MsgBox "Data Import Finished", vbInformation, un
    Else
        MsgBox "No Files Selected", vbExclamation, un
    End If
Else
    MsgBox "Cancelled", vbInformation, un
End If

proceedEnd:

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With

Exit Sub

errPlace:

For Each cll In ws.UsedRange.Resize(1)
    If Right(cll.Value, Len(seper)) = seper Then
        cll.Value = Left(cll.Value, Len(cll.Value) - Len(seper))
    End If
Next cll

MsgBox "An Error Occured" & vbNewLine & vbNewLine & _
"-->> Error No: " & Err.Number & vbNewLine & _
"-->> Error Description: " & Err.Description, vbExclamation, un

GoTo proceedEnd

End Sub
Private Function FindRowColumn(inpSht As Worksheet, sInp As String)

With inpSht
    If LCase(sInp) = "r" Then
        FindRowColumn = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, _
        LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    ElseIf LCase(sInp) = "c" Then
        FindRowColumn = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, _
        LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
        MatchCase:=False).Column
    Else
        FindRowColumn = 0
    End If
End With

End Function
Private Function CleanHeading(sInput As String) As String

CleanHeading = LCase(Trim(Application.Clean(sInput)))

End Function
Private Function fAvaRow(inpShtAva As Worksheet, inpC As Long, inpLastCol As Long)

Dim c As Long

fAvaRow = 0
For c = inpC To inpLastCol
    If inpShtAva.Cells(Rows.Count, c).End(xlUp).Row > fAvaRow Then
        fAvaRow = inpShtAva.Cells(Rows.Count, c).End(xlUp).Row
    End If
Next c
If fAvaRow <> 0 Then fAvaRow = fAvaRow + 1

End Function
Private Function CheckDataImport(inpDataSheet As Worksheet) As Boolean

Dim cll As Range

CheckDataImport = False
For Each cll In inpDataSheet.UsedRange.Resize(1).Cells
    If Right(cll.Value, Len(seper)) = seper Then
        CheckDataImport = True
        Exit Function
    End If
Next cll

End Function

bendeki kod