Yardım Makro hakkında yardım

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, 1).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"
                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