Help to amend this code to action all files

[Fuisdale2]

Hello,

I have the below code that works on selecting individual files in a folder and actions a column index and match.

Can anyone help amending the code so it can action all files instead of selecting one file one at a time.

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

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



<strike></strike>

 

[DushiPunda]

Please wrap your code in CODE tags...
That being said, here are some links that should be able to help you out:

https://www.mrexcel.com/forum/excel-questions/570444-run-macro-all-files.html
https://www.mrexcel.com/forum/excel...ing-range-one-file-multiple-files-folder.html

Let us know if you have any further questions.

 

[Fuisdale2]

Hello,

I have tried looking at historic thread and when I try and run the code its giving me an error message 9

 

[DushiPunda]

What is the entire error message and when you click the debug button, what is the highlighted line?

Please paste the code that you are running when you receive the error.

 

[Fuisdale2]

Hi Dushpunda

The Macro I am trying to run within the below code is called PDB_Import

Sub LoopThroughFiles()


FolderName = "C:\Users\PAH\Desktop\test"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
Fname = Dir(FolderName & "*.xls")
'loop through the files
Do While Len(Fname)
With Workbooks.Open(FolderName & Fname)
' here comes the code for the operations on every file the code finds
'HERE if you want to execute the second macro for every file in the loop
PDB_Import
End With
' go to the next file in the folder
Fname = Dir
Loop

End Sub


The error message I get is

Run time error 9
Subscript out of range

When I click on de bugger its showing this line of code:

Set wsCopyTo = wbCopyTo.Sheets("Imported_Data")
<strike></strike>

 

[DushiPunda]

Sounds like whatever workbook you have opened doesn't have a worksheet named "Imported_Data"...

In your LoopThroughFiles macro, this line will open a workbook and it will become the active workbook:

With Workbooks.Open(FolderName & Fname)

Then, in your PDB_Import macro:

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

...you're setting wbCopyTo to ActiveWorkbook (which, again, is the workbook you just opened)...and then you're setting wsCopyTo to the worksheet "Imported_Data" in the wbCopyTo workbook.

Which workbook contains the worksheet "Imported_Data"?

Also, be advised regarding these lines from PDB_Import:

Set wbCopyFrom = Workbooks.Open(vFile)
    Set wsCopyFrom = wbCopyFrom.Worksheets(1)

So, right now, you're doing this:

1. Open file in LoopThroughFiles
2. Call PDB_Import macro
3. Open another file

By the looks of it, in your PDB_Import macro, you need to replace all "ActiveWorkbook" with "ThisWorkbook" and set wbCopyFrom to "ActiveWorkbook".