VBA to action over 500 documents in a folder

[VBA learner ITG]

Hello,

I am new to VBA and still learning.

I was wondering if my peers could help me at all.

I have the below code which i am looking to run on over 500+ documents.

However the code has been written to action a single document at a time. Is there a smarter way of cycling through all documents in a folder?

Sub PDB_Import()

    Dim vFile       As Variant
    Dim wbCopyTo    As Workbook
    Dim wsCopyTo    As Worksheet
    Dim wbCopyFrom  As Workbook
    Dim wsCopyFrom  As Worksheet

    Set wbCopyTo = ActiveWorkbook
    Set wsCopyTo = wbCopyTo.Sheets("Imported_Data")

Application.DisplayAlerts = False
    
    vFile = Application.GetOpenFilename
    
    If TypeName(vFile) = "Boolean" Then
        Exit Sub
    Else
    Set wbCopyFrom = Workbooks.Open(vFile)
    Set wsCopyFrom = wbCopyFrom.Worksheets(1)
    End If
    
Set oneRange = Range("A1:ll5000")
Set aCell = Range("A1")

'oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
    
    wsCopyFrom.Range("a9:ll5000").Copy
    wsCopyTo.Range("a1").PasteSpecial Paste:=xlValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False

wbCopyFrom.Close False

Application.ScreenUpdating = False
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

Dim intErrCount As Integer

' create worksheet objects
Dim shtSource As Worksheet: Set shtSource = Sheets("Imported_Data")
Dim shtTarget As Worksheet: Set shtTarget = Sheets("Database")

' create range objects
Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("A1:BB1")

With shtTarget
    Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A1:AB1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:AB1")
    Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
    End With
    

Dim rngDataColumn As Range

' process data
Dim cl As Range, i As Integer
For Each cl In rngTargetHeaders ' loop through each cell in target header row
    
    ' identify source location
    i = 0 ' reset I
    On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
        i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
    On Error GoTo 0 ' switch error handling back off
    
    ' report if source location not found
    If i = 0 Then
        intErrCount = intErrCount + 1
        Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
        GoTo nextCL
    End If
    
    ' create source data range object
    With rngSourceHeaders.Cells(1, i)
        Set rngDataColumn = Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))
    End With
    
    ' pass to target range object
    shtTarget.Cells(Rows.Count, cl.Column).End(xlUp).Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value
    
    
nextCL:
Next cl

' confirm process completion and issue any warnings
If intErrCount = 0 Then
    MsgBox "process completed", vbInformation
Else
    MsgBox "WARNING: " & intErrCount & " issues encountered. Check VBA log for details", vbExclamation
End If

Sheets("Database").Select
Range("A1").Select
    
End Sub

[kasan]

Hi,
Try this way:

Sub PDB_Import()

    Dim vFile       As Variant
    Dim wbCopyTo    As Workbook
    Dim wsCopyTo    As Worksheet
    Dim wbCopyFrom  As Workbook
    Dim wsCopyFrom  As Worksheet

    Set wbCopyTo = ActiveWorkbook
    Set wsCopyTo = wbCopyTo.Sheets("Imported_Data")

Application.DisplayAlerts = False
    

Dim strFileName As String, strPath As String  

strPath = "C:\abc\" 'folder with all files
strFileName = Dir(strPath & "*.xlsx")


Do While Len(strFileName) > 0

Set wbCopyFrom = Workbooks.Open(strPath & strFileName)


'your code here


strFileName = Dir 'next file

wbCopyFrom.Close False


Loop


End Sub

[VBA learner ITG]

Hi Kasan,

Thank you for replying.

I have tried your amended code and also stepping into the code and it hasn't worked.

are you able to elaborate on your code?