Match and then Copy/Paste based on dates

[Wheelie686]

What I would like to do is put in a Dept Code in B1 on my Summary doc, find said Dept Code in my Call Placement doc and then bring back the months' data and paste into the appropriate months' column(s) on the Summary doc.

I've created a Worksheet_Change sub on the doc but not sure how to get started copying/pasting the data from one doc to another. The issue I can't seem to overcome is that the number of columns in the Work Placement document could change depending on the current month. For instance if it's December 2024, it'll just have 1 column. If it's January 2024, it'll have 12... and anywhere in between.

Any help anyone could provide would be appreciated.

[Aussiebear]

Welcome to VBAX Wheelie686. Would it be possible to filter your data based on Dept Code?

[Wheelie686]

Hi Aussiebear,
There's an automatic macro that'll trigger if you have both files open and type a proper code in B1 on the Summary doc. Here's what it would look like with code 1501. I added "v2" to the title so you can differentiate if you want.

[georgiboy]

Perhaps you could try it without using filter:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Dim YEE As Workbook
Dim ws As Worksheet
Dim uCols As Integer
Dim sMnth As Date
Dim dRng As Range

For Each wb In Workbooks
If wb.Name Like "YEE*call placement*" Then
Set YEE = wb
Exit For
End If
Next wb

If Target.Address = "$B$1" Then
For Each ws In YEE.Worksheets
If ws.Name Like "YEE*DEPT*" Then
uCols = ws.UsedRange.Columns.Count
sMnth = ws.Range("B1").Value
Set dRng = ws.Range("A:A").Find(Target.Value, , , xlWhole)
Range("B4:Y4").ClearContents
dRng.Offset(, 1).Resize(, uCols - 2).Copy
Rows(3).Find(sMnth, , , xlWhole).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
End If
Next ws
End If
End Sub

[Wheelie686]

So it looks perfect except when I tried to transfer it to my "official" document - I had used more of a template that had sensitive info removed. The trouble comes up because some of my rows/columns don't quite match what I had sent you before. I believe I fixed everything but the Copy line. Based on the attached documents, would you be able to advise how to modify the code? As you can see, it's pulling June to December PLUS Column N (and maybe a few blank columns).

[georgiboy]

Maybe you could try it as below then:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Dim YEE As Workbook
Dim ws As Worksheet
Dim uCols As Integer
Dim sMnth As Date
Dim dRng As Range

Application.EnableEvents = False

For Each wb In Workbooks
If wb.Name Like "*YEE*call placement*" Then
Set YEE = wb
Exit For
End If
Next wb

If Target.Address = "$B$4" Then
For Each ws In YEE.Worksheets
If ws.Name Like "YEE*MU*" Then
uCols = ws.UsedRange.Columns.Count
sMnth = ws.Range("G1").Value
Set dRng = ws.Range("F:F").Find(Target.Value, , , xlWhole)
Range("B10:Y10").ClearContents
ws.Range(ws.Cells(dRng.Row, dRng.Column + 1), ws.Cells(dRng.Row, uCols - 1)).Copy
Rows(9).Find(sMnth, , , xlWhole).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
Exit For
End If
Next ws
End If

Application.EnableEvents = True
End Sub

[Wheelie686]

Perfect! Now I see what I did wrong. Thanks!

[georgiboy]

Happy to help.

Here is another option without using copy/ paste:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Dim YEE As Workbook
Dim ws As Worksheet
Dim uCols As Integer
Dim sMnth As Date
Dim dRng As Range, cRng As Range

Application.EnableEvents = False

For Each wb In Workbooks
If wb.Name Like "*YEE*call placement*" Then
Set YEE = wb
Exit For
End If
Next wb

If Target.Address = "$B$4" Then
For Each ws In YEE.Worksheets
If ws.Name Like "YEE*MU*" Then
uCols = ws.UsedRange.Columns.Count
sMnth = ws.Range("G1").Value
Set dRng = ws.Range("F:F").Find(Target.Value, , , xlWhole)
Range("B10:Y10").ClearContents
Set cRng = ws.Range(ws.Cells(dRng.Row, dRng.Column + 1), ws.Cells(dRng.Row, uCols - 1))
Rows(9).Find(sMnth, , , xlWhole).Offset(1).Resize(, cRng.Columns.Count) = cRng.Value
Exit For
End If
Next ws
End If

Application.EnableEvents = True
End Sub

[Wheelie686]

After testing it on & off this morning, I did notice something that I didn't expect to happen - if I end up triggering the macro without having the Call Placement file open (not that that would happen much but running a separate macro ended up triggering it). Once it tries to trigger without the Call Placement file, if I try to purposely trigger it, it just sits there doing nothing. It will only work if I re-open both files. Not a huge hassle but definitely not what I expected.
I think my better option would be to just make it a regular macro that I trigger with a button - I already have 3 others so adding a 4th button wouldn't be the end of the world for me.
Would you know how to switch it to a regular macro? I have the following but the line I put in bold comes back with a runtime 424 error.


Sub TEST()
Dim wb As Workbook
Dim YEE As Workbook
Dim ws As Worksheet
Dim uCols As Integer
Dim sMnth As Date
Dim dRng As Range

Application.EnableEvents = False

For Each wb In Workbooks
If wb.Name Like "*YEE*call placement*" Then
Set YEE = wb
Exit For
End If
Next wb

'If Target.Address = "$B$4" Then
For Each ws In YEE.Worksheets
If ws.Name Like "YEE*MU*" Then
uCols = ws.UsedRange.Columns.Count
sMnth = ws.Range("G1").Value
Set dRng = ws.Range("F:F").Find(Target.Value, , , xlWhole)
Range("B10:Y10").ClearContents
ws.Range(ws.Cells(dRng.Row, dRng.Column + 1), ws.Cells(dRng.Row, uCols - 1)).Copy
Rows(9).Find(sMnth, , , xlWhole).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
Exit For
End If
Next ws
'End If

ThisWorkbook.Sheets("YEE").Range("B4").Select


Application.EnableEvents = True


End Sub

[georgiboy]

You can still run it the way it was originally, I have added some error handling in the below to check if the call placement spreadsheet is open:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Dim YEE As Workbook
Dim ws As Worksheet
Dim uCols As Integer
Dim sMnth As Date
Dim dRng As Range, cRng As Range

Application.EnableEvents = False

For Each wb In Workbooks
If wb.Name Like "*YEE*call placement*" Then
Set YEE = wb
Exit For
End If
Next wb

If YEE Is Nothing Then
Application.EnableEvents = True
MsgBox "Call placement spreadsheet not open"
Exit Sub
End If

If Target.Address = "$B$4" Then
For Each ws In YEE.Worksheets
If ws.Name Like "YEE*MU*" Then
uCols = ws.UsedRange.Columns.Count
sMnth = ws.Range("G1").Value
Set dRng = ws.Range("F:F").Find(Target.Value, , , xlWhole)
Range("B10:Y10").ClearContents
Set cRng = ws.Range(ws.Cells(dRng.Row, dRng.Column + 1), ws.Cells(dRng.Row, uCols - 1))
Rows(9).Find(sMnth, , , xlWhole).Offset(1).Resize(, cRng.Columns.Count) = cRng.Value
Exit For
End If
Next ws
End If

Application.EnableEvents = True
End Sub

As for other subs triggering your worksheet event, you can disable events in those macro's using the below method. It will stop them from triggering events when they make changes to the worksheet:

Sub test()

Application.EnableEvents = False

' Your code here
' Your code here
' Your code here

Application.EnableEvents = True

End Sub

For each of your other subs that interact with the sheet with the event code you would add the false line from above test macro, run all of your code, then use the true line from above test macro.

[georgiboy]

As for post 9, In your bold line.

Set dRng = ws.Range("F:F").Find(Target.Value, , , xlWhole)


This:

Target.Value
would need to be replaced with something like:

Range("B4").Value

[Wheelie686]

I can't thank you enough for the help on this. To be honest I didn't want to abandon the Worksheet_Change function so getting the error handling right wasn't something I thought of but I'm not as well versed in doing that so I appreciate your help. This will help me learn some things about VBA that I wasn't quite getting right.