PDA

View Full Version : VBA copy data to matching workbook



msquared99
04-21-2015, 08:52 AM
OK, I have been struggling with this for a while. Here is what I am trying to do.
1. I have a folder with several workbooks in it. They are named like this Mike MM-YY.xlsx
2. I have another workbook called Intercompany. Column D contains the name matching the workbook name in item 1 but excludes the date. Columns G thru AD contain MM Revenue and MM Commission for each month.

What I am trying to do is if a workbook exists in item 1, then copy the data from the Intercompany workbook into the workbook in item 1 on a new worksheet named "IC". So if Mike MM-YY exists then match Mike for Mike and copy the matching rows of data into the existing workbook. The other issue is to copy only the columns of data needed for the revenue. So, the macro copies the rows of data from columns A thru F, then say columns K and M, which would be March Revenue and March Commission.

I am bumfuzzled about how to do this but have been trying.

Attached is my code as I did not see how to post it in the thread.

Thanks for anyone's time.

mancubus
04-22-2015, 05:21 AM
When you click # button in Quick Reply code tags (without spaces) will be inserted.

[ CODE ]paste your code between these tags[ /CODE ]

msquared99
04-27-2015, 11:27 AM
Below is the code:

Sub IC_Commissions()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim VariableFN As String
Dim FinalRow As Long
Dim WBIC As Workbook
Dim WSIC As Worksheet
Dim rng As Range

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User, example Ash 03-15.xlsx
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
Do While myFile <> ""

'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)

'This line extracts the Rep Name from the file name
s = Left(myFile, InStr(myFile, " "))

'**************************************************************
'With opened workbook add a sheet and rename
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "IC"
Sheets("IC").Move After:=Sheets(2)

Sheets("IC").Select 'Setup column headers
With Sheets
Range("A1").Value = ("Client Name")
Range("B1").Value = ("Service")
Range("C1").Value = ("St. Date")
Range("D1").Value = ("Rep")
Range("E1").Value = ("1st Yr. Comm")
Range("F1").Value = ("Residual Commission")
Range("G1").Value = ("IC Revenue")
Range("H1").Value = ("Commission")
Columns("A:H").Select
Selection.Font.Bold = True
Columns("A:H").AutoFit
Range("A1").Select
End With



'***************************************************************
'Open IC workbook and sort data, then copy matching data to opened workbook aka myFile
Workbooks.Open "C:\Test Commissions\2015 Intercompany Billing.xls*"
'Set WBIC = Application.Workbooks("2015 Intercompany Billing.xls*")

Sheets("Commissions").Select


Range("A1").Select
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A1:AD" & FinalRow)
rng.Select

'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Commissions").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Commissions").Sort.SortFields.Add Key:=Range( _
"D2:D" & FinalRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal

With ActiveWorkbook.Worksheets("Commissions").Sort
.SetRange Range("A1:AD" & FinalRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


'Filter data here and loop through it
For Each s In rng
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AD$" & FinalRow).AutoFilter Field:=4, Criteria1:=s
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

wb.Activate 'MACRO STOPS HERE
Sheets("IC").Select
Range("A1").Select
ActiveSheet.Paste


'***************************************************************


wb.Close SaveChanges:=True
'Get next file name
myFile = Dir

Next s
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

mancubus
04-28-2015, 02:02 AM
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

msquared99
04-28-2015, 06:40 AM
Thank you for your time mancubus! In testing the code I get an error on this line:


ColNum = .Rows(1).Find(RowHeads(i)).Column

The error is: Run-time error 91 Object variable or With block variable not set

I tried several different changes to declaring RowHeads as a Variant or Set before ColHeads but kept getting different errors such as Complie Error or Run-Time Error 13.

In the Locals window it looks like the array does not fill.

Any thoughts?

Thanks for your time!

mancubus
04-28-2015, 07:00 AM
you are welcome.

i seems a typo.

try changing
ColNum = .Rows(1).Find(RowHeads(i)).Column
to
ColNum = .Rows(1).Find(ColHeads(i)).Column

msquared99
04-28-2015, 07:15 AM
I still get the same error on the same line. When I hover over ColNum it says "Empty"

mancubus
04-28-2015, 07:32 AM
can you post your workbook (replace sensitive data with some values)

msquared99
04-28-2015, 07:59 AM
OK, I have attached an example.

mancubus
04-28-2015, 12:14 PM
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"


for the code i posted, row 1 of Sheet1 in 2015 Intercompany Billing.xls should contain the above column heads. since there is no Client Name in column headers the code errors out.
also there is no "St. Date" but "Start Date".

i think A1 value should be "Client Name" and not "2015".

the code determines the columns to get copied based on these column header.

after replacing "2015" with "Client Name" in A1 of Sheet1 (or "Client Name" with "2015" in ColHeads variable)

change
ColHeads = Array("Client Name", "Service", "St. Date", "Rep", "1st Yr. Comm", "Residual Commission", "IC Revenue", "Commission")
to
ColHeads = Array("Client Name", "Service", "Start Date", "Rep", "First Year Comm %", "Residual Commission", "March IC Revenue", "March Commission")

msquared99
04-28-2015, 12:56 PM
maccubus,

If you were a woman I would kiss you! It worked perfect!!!!!

THANK YOU SOOO much for your help!

I really learned a lot from trying to fix the code myself then seeing what you came up with.

The beauty of the code is that from column G thru AD, they contain each month of the year. I tested the code with all the months (Jan-Mar) in the IC Workbook and it works fine. It is almost like SQL in that it identifies the column by name and extracts that data. Pretty slick!

Again, I express my gratitude and appreciation for your help.

Mike

msquared99
05-13-2015, 07:10 AM
I just found out the code is doing a little something odd, if a match is not found in the IC workbook, it copies all the data from the IC workbook into the Reps workbook. So if Smith 04-15.xlsx does not have a match in the Intercompany Workbook, it copies all the data from the Intercompany workbook into Smith 04-15.xlsx.

The seems to be with this block of code:


With wsIC
.Cells(1).AutoFilter Field:=4, Criteria1:="=" & RepName
With .AutoFilter.Range
'WORKING HERE,.SpecialCells(xlCellTypeVisible) IS AN ISSUE
If .SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then 'there is at least 1 row which meets the filter criteria
For i = LBound(ColHeads) To UBound(ColHeads)
ColNum = .Rows(1).Find(ColHeads(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

msquared99
05-13-2015, 12:03 PM
I'm good, I see the issue.