i assume "Client Name", "Service", "St. Date", "Rep", "1st Yr. Comm", "Residual Commission", "IC Revenue", "Commission" are Column headers in worksheet "Commissions" of workbook "2015 Intercompany Billing.xls"
obviously, not tested. test the code with a backup of all folders and files.
Sub IC_Commissions()
Dim wb As Workbook, wbIC As Workbook, wsIC As Worksheet
Dim myPath As String, myFile As String, myExtension As String, RepName As String
Dim ColHeads As Variant
Dim calc As Long
'Optimize Macro Speed
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
With Application.FileDialog(msoFileDialogFolderPicker) 'Retrieve Target Folder Path From User, example Ash 03-15.xlsx
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then 'In Case of Cancel
MsgBox "Please select target folder. Quitting..."
GoTo ResetSettings
End If
myPath = .SelectedItems(1) & "\"
End With
'Open IC workbook if not already open and sort data in sheet Commissions
On Error Resume Next
Set wbIC = Workbooks("C:\Test Commissions\2015 Intercompany Billing.xls*")
If wbp Is Nothing Then 'it is not open
Set wbIC = Workbooks.Open("C:\Test Commissions\2015 Intercompany Billing.xls*")
End If
Set wsIC = wbIC.Worksheets("Commissions")
With wsIC 'sort asc in Col D
.Cells(1).Sort Key1:=.Range("D2"), Order1:=xlAscending, Header:=xlYes
End With
On Error GoTo 0
ColHeads = Array("Client Name", "Service", "St. Date", "Rep", "1st Yr. Comm", "Residual Commission", "IC Revenue", "Commission")
myExtension = "*.xlsx" 'Target File Extension (must include wildcard "*")
myFile = Dir(myPath & myExtension) 'Target Path with Ending Extention
Do While myFile <> "" 'Loop through each Excel file in folder
Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Set variable equal to opened workbook
wb.Worksheets.Add(After:=Worksheets(1)).Name = "IC" 'With opened workbook add a sheet and rename
With Worksheets("IC")
.Range("A1:H1").Value = ColHeads
.Range("A1:H1").Font.Bold = True
.Columns("A:H").AutoFit
End With
RepName = Left(myFile, InStr(myFile, " ") - 1) 'extracts the Rep Name from the file name. -1 for removing space
'copy matching data from IC to opened workbook aka myFile
With wsIC
.Cells(1).AutoFilter Field:=4, Criteria1:="=" & RepName
With .AutoFilter.Range
If .Rows.Count > 1 Then 'there is at least 1 row which meet filter criteria
For i = LBound(ColHeads) To UBound(ColHeads)
ColNum = .Rows(1).Find(RowHeads(i)).Column
.Columns(ColNum).Offset(1).Resize(.Rows.Count - 1).Copy Destination:=wb.Worksheets("IC").Cells(2, i + 1)
'offset 1 row to exclude the header row. +1 for first value of i = 0 ColHeads is zero based array
Next i
End If
End With
End With
wb.Close SaveChanges:=True
myFile = Dir 'Get next file name
Loop
wbIC.Close False 'close Intercompany Billing workbook without saving
MsgBox "Task Complete!" 'Message Box when tasks are completed
ResetSettings: 'Reset Macro Optimization Settings
With Application
.EnableEvents = True
.Calculation = calc
End With
End Sub
Reply With Quote
Originally Posted by mancubus
