Copy columns from one sheet to another based on dates matching

S

shelly468

New Member
Joined
Jun 21, 2023
Messages
5
Office Version
  1. 365
Platform
  1. MacOS
I have several columns associated with dates that are variable and changes depending on data input into the spreadsheet. Therefore sometimes the first columns start in the middle of a week.

I would like for the document to automatically determine which columns are associated with the first Monday in the range and copy those columns and all columns ahead of it to another sheet in the workbook.

Eg. If the first column was a Friday, I want it to skip the columns from Friday until it reaches Monday and then copy all columns ahead of Monday with data.

Is this possible with formulas or VBA? Any help would be greatly appreciated.
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Hi, It would be good if you can provide some sample data through mini sheet via XLBB with expected result for better understanding
  • Want to help your helpers by posting a small, copyable, screen shot directly in your post? XL2BB Instructions & Download (latest January 2021 v 2.0 )
 
Upvote 0
RudRud said:
Hi, It would be good if you can provide some sample data through mini sheet via XLBB with expected result for better understanding
  • Want to help your helpers by posting a small, copyable, screen shot directly in your post? XL2BB Instructions & Download (latest January 2021 v 2.0 )
Click to expand...
Essentially, each day has 3 columns associated with it. The first day in the range changes depending on certain information input into the spreadsheet elsewhere. Currently in the example it is starting on a Friday. What I would like to do, using either formulas or VBA, is to find the first instance that is a Monday in row 2 (in this case column w) (row 2 is normally white writing so not visible) and copy all columns with data from that Monday onwards and put it onto a seperate sheet.

I hope that makes sense.

Personalised Group Dining Chart Test copy.xlsm
MNOPQRSTUVWXYZAAABACADAEAFAGAH
1
215/9/2315/9/2315/9/2316/9/2316/9/2316/9/2317/9/2317/9/2317/9/2318/9/2318/9/2318/9/2319/9/2319/9/2319/9/2320/9/2320/9/2320/9/2321/9/2321/9/2321/9/23
3Friday 15thSaturday 16thSunday 17thMonday 18thTuesday 19thWednesday 20thThursday 21st
4
5StartFinishStartFinishStartFinishStartFinish      
6
7Breakfast       
8Dinner       
9
10      StartFinishStartFinishStartFinishStartFinish
11
12Breakfast       
13Dinner       
14
15    StartFinishStartFinishStartFinishStartFinishStartFinish
16
17Breakfast       
18Dinner       
19
20              
21
22        
23        
Input
Cell Formulas
RangeFormula
N2N2=Sheet1!AN17
O2O2=Sheet1!AN17
P2P2=Sheet1!AN17
Q2Q2=Sheet1!AN18
R2R2=Sheet1!AN18
S2S2=Sheet1!AN18
T2T2=Sheet1!AN19
U2U2=Sheet1!AN19
V2V2=Sheet1!AN19
W2W2=Sheet1!AN20
X2X2=Sheet1!AN20
Y2Y2=Sheet1!AN20
Z2Z2=Sheet1!AN21
AA2AA2=Sheet1!AN21
AB2AB2=Sheet1!AN21
AC2AC2=Sheet1!AN22
AD2AD2=Sheet1!AN22
AE2AE2=Sheet1!AN22
AF2AF2=Sheet1!AN23
AG2AG2=Sheet1!AN23
AH2AH2=Sheet1!AN23
N3N3=IF(Sheet1!AT17="True",0,Sheet1!AS17)
N5N5=IF(Sheet1!AU17=TRUE,"Start","")
O5,AG20,AD20,AA20,X20,U20,R20,O20,AG15,AD15,AA15,X15,U15,R15,O15,AG10,AD10,AA10,X10,U10,R10,O10,AG5,AD5,AA5,X5,U5,R5O5=IF(N5="","","Finish")
Q3Q3=IF(Sheet1!AT18="True",0,Sheet1!AS18)
Q5Q5=IF(Sheet1!AU18=TRUE,"Start","")
T3T3=IF(Sheet1!AT19="True",0,Sheet1!AS19)
T5T5=IF(Sheet1!AU19=TRUE,"Start","")
W3W3=IF(Sheet1!AT20="True",0,Sheet1!AS20)
W5W5=IF(Sheet1!AU20=TRUE,"Start","")
Z3Z3=IF(Sheet1!AT21="True",0,Sheet1!AS21)
Z5Z5=IF(Sheet1!AU21=TRUE,"Start","")
AC3AC3=IF(Sheet1!AT22="True",0,Sheet1!AS22)
AC5AC5=IF(Sheet1!AU22=TRUE,"Start","")
AF3AF3=IF(Sheet1!AT23="True",0,Sheet1!AS23)
AF5AF5=IF(Sheet1!AU23=TRUE,"Start","")
M7,M22,M17,M12M7=IF(D5="","","Breakfast")
M8,M23,M18,M13M8=IF(D5="","","Dinner")
P7:P8,AH12:AH13,AE12:AE13,AB12:AB13,Y12:Y13,V12:V13,S12:S13,P12:P13,AH7:AH8,AB7:AB8,Y7:Y8,V7:V8,S7:S8P7=IF(ISNUMBER(N7),"O","")
AE7:AE8AE7=IF(ISNUMBER(AC7),"R","")
N10N10=IF(Sheet1!AV17=TRUE,"Start","")
Q10Q10=IF(Sheet1!AV18=TRUE,"Start","")
T10T10=IF(Sheet1!AV19=TRUE,"Start","")
W10W10=IF(Sheet1!AV20=TRUE,"Start","")
Z10Z10=IF(Sheet1!AV21=TRUE,"Start","")
AC10AC10=IF(Sheet1!AV22=TRUE,"Start","")
AF10AF10=IF(Sheet1!AV23=TRUE,"Start","")
N15N15=IF(Sheet1!AW17=TRUE,"Start","")
Q15Q15=IF(Sheet1!AW18=TRUE,"Start","")
T15T15=IF(Sheet1!AW19=TRUE,"Start","")
W15W15=IF(Sheet1!AW20=TRUE,"Start","")
Z15Z15=IF(Sheet1!AW21=TRUE,"Start","")
AC15AC15=IF(Sheet1!AW22=TRUE,"Start","")
AF15AF15=IF(Sheet1!AW23=TRUE,"Start","")
P17:P18,AH17:AH18,AE17:AE18,AB17:AB18,Y17:Y18,V17:V18,S17:S18P17=IF(ISNUMBER(N17),"Y","")
N20N20=IF(Sheet1!AX17=TRUE,"Start","")
Q20Q20=IF(Sheet1!AX18=TRUE,"Start","")
T20T20=IF(Sheet1!AX19=TRUE,"Start","")
W20W20=IF(Sheet1!AX20=TRUE,"Start","")
Z20Z20=IF(Sheet1!AX21=TRUE,"Start","")
AC20AC20=IF(Sheet1!AX22=TRUE,"Start","")
AF20AF20=IF(Sheet1!AX23=TRUE,"Start","")
P22:P23,AH22:AH23,AE22:AE23,AB22:AB23,Y22:Y23,V22:V23,S22:S23P22=IF(ISNUMBER(N22),"LG","")
 
Upvote 0
Book3
MNOPQRSTUVWXYZAAABACADAEAFAGAHAI
215/9/2315/9/2315/9/2316/9/2316/9/2316/9/2317/9/2317/9/2317/9/2318/9/2318/9/2318/9/2319/9/2319/9/2319/9/2320/9/2320/9/2320/9/2321/9/2321/9/2321/9/23
3Friday 15thSaturday 16thSunday 17thMonday 18thTuesday 19thWednesday 20thThursday 21st
4
5StartFinishStartFinishStartFinishStartFinish
6
7Breakfast
8Dinner
9
10StartFinishStartFinishStartFinishStartFinish
11
12Breakfast
13Dinnerwerwer
14
15StartFinishStartFinishStartFinishStartFinishStartFinish
16rwerw
17Breakfast
18Dinner
19
20
Sheet1


Monday sheet
Book3
ABC
218/9/2318/9/2318/9/23
3Monday 18th
4
5StartFinish
6
7
8
9
10StartFinish
11
12
13werwer
14
15StartFinish
16rwerw
17
18
19
20
21
22
23
24
Monday 18th


Please give a shot @shelly468 and let me know if this's youre looking for

For now this code only find first monday

VBA Code: 
Option Compare Text
Option Explicit
Sub Test()
Dim dict As Object
Dim ws As Worksheet
Dim f As Range
Dim i, lastcol, lrow%
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = VBTextCompare
Set ws = ThisWorkbook.Sheets("sheet1")

'record current worksheets name
For i = 1 To Worksheets.Count
    dict.Add Sheets(i).Name, ""
Next i

With ws
    lastcol = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set f = .Range(.Cells(3, "m"), .Cells(4, lastcol)).Find("monday", LookIn:=xlValues) 'Find monday
End With

'If already existing sheet, then just replacing the values, If not create new sheet
If f <> "" Then
    If dict.exists(f.Value) Then
        Sheets(f.Value).Range("a:c").Clear
    Else
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = f.Value
    End If

    With ws
        lrow = .Cells(Rows.Count, f.Column).End(xlUp).Row
        .Range(.Cells(2, f.Column), .Cells(lrow, f.Column + 2)).Copy Sheets(f.Value).Range("a2")
    End With
End If


End Sub
 
Upvote 0
RudRud said:
Book3
MNOPQRSTUVWXYZAAABACADAEAFAGAHAI
215/9/2315/9/2315/9/2316/9/2316/9/2316/9/2317/9/2317/9/2317/9/2318/9/2318/9/2318/9/2319/9/2319/9/2319/9/2320/9/2320/9/2320/9/2321/9/2321/9/2321/9/23
3Friday 15thSaturday 16thSunday 17thMonday 18thTuesday 19thWednesday 20thThursday 21st
4
5StartFinishStartFinishStartFinishStartFinish
6
7Breakfast
8Dinner
9
10StartFinishStartFinishStartFinishStartFinish
11
12Breakfast
13Dinnerwerwer
14
15StartFinishStartFinishStartFinishStartFinishStartFinish
16rwerw
17Breakfast
18Dinner
19
20
Sheet1


Monday sheet
Book3
ABC
218/9/2318/9/2318/9/23
3Monday 18th
4
5StartFinish
6
7
8
9
10StartFinish
11
12
13werwer
14
15StartFinish
16rwerw
17
18
19
20
21
22
23
24
Monday 18th


Please give a shot @shelly468 and let me know if this's youre looking for

For now this code only find first monday

VBA Code: 
Option Compare Text
Option Explicit
Sub Test()
Dim dict As Object
Dim ws As Worksheet
Dim f As Range
Dim i, lastcol, lrow%
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = VBTextCompare
Set ws = ThisWorkbook.Sheets("sheet1")

'record current worksheets name
For i = 1 To Worksheets.Count
    dict.Add Sheets(i).Name, ""
Next i

With ws
    lastcol = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set f = .Range(.Cells(3, "m"), .Cells(4, lastcol)).Find("monday", LookIn:=xlValues) 'Find monday
End With

'If already existing sheet, then just replacing the values, If not create new sheet
If f <> "" Then
    If dict.exists(f.Value) Then
        Sheets(f.Value).Range("a:c").Clear
    Else
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = f.Value
    End If

    With ws
        lrow = .Cells(Rows.Count, f.Column).End(xlUp).Row
        .Range(.Cells(2, f.Column), .Cells(lrow, f.Column + 2)).Copy Sheets(f.Value).Range("a2")
    End With
End If


End Sub
Click to expand...
Hi @RudRud,

I'm sorry, I'm fairly new to VBA so please bare with me.

I put the above into Module1 of my workbook. Initially it didn't do anything so I created a button on the page with the macro assigned to it. When pressing the button it gives an error saying ActiveX component can't create object. The line Set dict = CreateObject("Scripting.Dictionary") is highlighted yellow.
 
Upvote 0
just realise that you're using MacOS, Please import dictionary.cls into class module in order to access dictionary in MacOS as the step below:

github.com

Releases · VBA-tools/VBA-Dictionary

Drop-in replacement for Scripting.Dictionary on Mac - VBA-tools/VBA-Dictionary
github.com github.com


click source code zip
1685799199285.png


1685799131949.png


1685799150214.png


1685799172630.png


After imported dictionary.cls into class module,

Right Click Sheet1 -> View Code -> Paste below code

VBA Code: 
Option Compare Text
Option Explicit
Sub Test()
Dim dict As New Dictionary
Dim ws As Worksheet
Dim f As Range
Dim i, lastcol, lrow%
Set ws = ThisWorkbook.Sheets("sheet1")

'record current worksheets name
For i = 1 To Worksheets.Count
    dict.Add Sheets(i).Name, ""
Next i

With ws
    lastcol = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set f = .Range(.Cells(3, "m"), .Cells(4, lastcol)).Find("monday", LookIn:=xlValues) 'Find monday
End With

'If already existing sheet, then just replacing the values, If not create new sheet
If f <> "" Then
    If dict.exists(f.Value) Then
        Sheets(f.Value).Range("a:c").Clear
    Else
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = f.Value
    End If

    With ws
        lrow = .Cells(Rows.Count, f.Column).End(xlUp).Row
        .Range(.Cells(2, f.Column), .Cells(lrow, f.Column + 2)).Copy Sheets(f.Value).Range("a2")
    End With
End If
End Sub
 
Upvote 0
RudRud said:
just realise that you're using MacOS, Please import dictionary.cls into class module in order to access dictionary in MacOS as the step below:

github.com

Releases · VBA-tools/VBA-Dictionary

Drop-in replacement for Scripting.Dictionary on Mac - VBA-tools/VBA-Dictionary
github.com github.com


click source code zip
1685799199285.png


1685799131949.png


1685799150214.png


1685799172630.png


After imported dictionary.cls into class module,

Right Click Sheet1 -> View Code -> Paste below code

VBA Code: 
Option Compare Text
Option Explicit
Sub Test()
Dim dict As New Dictionary
Dim ws As Worksheet
Dim f As Range
Dim i, lastcol, lrow%
Set ws = ThisWorkbook.Sheets("sheet1")

'record current worksheets name
For i = 1 To Worksheets.Count
    dict.Add Sheets(i).Name, ""
Next i

With ws
    lastcol = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set f = .Range(.Cells(3, "m"), .Cells(4, lastcol)).Find("monday", LookIn:=xlValues) 'Find monday
End With

'If already existing sheet, then just replacing the values, If not create new sheet
If f <> "" Then
    If dict.exists(f.Value) Then
        Sheets(f.Value).Range("a:c").Clear
    Else
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = f.Value
    End If

    With ws
        lrow = .Cells(Rows.Count, f.Column).End(xlUp).Row
        .Range(.Cells(2, f.Column), .Cells(lrow, f.Column + 2)).Copy Sheets(f.Value).Range("a2")
    End With
End If
End Sub
Click to expand...

Sorry for taking so long to get back to you.

Thank you for your help, I really appreciate it however, I attempted to try your code but it wasn't working for me. Through some research I found an option where I dynamically change the headers in row 1 through another sheet which also leaves blank the columns that I don't need. Now the headers show for each column Monday 1, Monday 2, Monday 3, Tuesday 1 and so on for each day and leaves blank headers for the days I don't want to copy. This means every column has a unique header. This all works perfectly.
I then found the following code and put it into Module 2 of the workbook: (Module 1 has other codes in for the same document)

VBA Code: 
Sub Monday1BD()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Input") '<== Sheet that has raw data
Dim LRow As Long, Found As Range

Set Found = ws.Range("A1:AQ1").Find("Monday 1") '<== Header name to search for

If Not Found Is Nothing Then
    LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
    ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
    Sheets("BD").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If

End Sub

I created a seperate sub as above for each day that I needed and then created a call sub so I can assign it to a button in my worksheet to activate all three macros to copy columns.

VBA Code: 
Sub BD_Button()
    Call Monday1BD
    Call Monday2BD
    Call Monday3BD
End Sub

This was working yesterday for me. I would press the button and it would process and copy all the data in the columns over to another worksheet.
Today however, when I reopened the document the button no longer works and when I go into the VB code and try to run individual sections it won't do anything anymore and doesn't copy the column over. Any idea why this would be? Other codes are still working perfectly fine in the same workbook meaning I haven't accidentally disabled macros. I'm really stumped and frustrated that it just stopped working.
 
Upvote 0
shelly468 said:
Sorry for taking so long to get back to you.

Thank you for your help, I really appreciate it however, I attempted to try your code but it wasn't working for me. Through some research I found an option where I dynamically change the headers in row 1 through another sheet which also leaves blank the columns that I don't need. Now the headers show for each column Monday 1, Monday 2, Monday 3, Tuesday 1 and so on for each day and leaves blank headers for the days I don't want to copy. This means every column has a unique header. This all works perfectly.
I then found the following code and put it into Module 2 of the workbook: (Module 1 has other codes in for the same document)

VBA Code: 
Sub Monday1BD()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Input") '<== Sheet that has raw data
Dim LRow As Long, Found As Range

Set Found = ws.Range("A1:AQ1").Find("Monday 1") '<== Header name to search for

If Not Found Is Nothing Then
    LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
    ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
    Sheets("BD").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If

End Sub

I created a seperate sub as above for each day that I needed and then created a call sub so I can assign it to a button in my worksheet to activate all three macros to copy columns.

VBA Code: 
Sub BD_Button()
    Call Monday1BD
    Call Monday2BD
    Call Monday3BD
End Sub

This was working yesterday for me. I would press the button and it would process and copy all the data in the columns over to another worksheet.
Today however, when I reopened the document the button no longer works and when I go into the VB code and try to run individual sections it won't do anything anymore and doesn't copy the column over. Any idea why this would be? Other codes are still working perfectly fine in the same workbook meaning I haven't accidentally disabled macros. I'm really stumped and frustrated that it just stopped working.
Click to expand...

What is the cause of the error? I noticed a small difference in the column values between your code and mine when I read it. That is why it did not work out.

1687584527526.png


Your code Monday is in Row1 while previous that you've shared in row 3 , Would you mind to share your input sheets instead to have it checked?
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Copy & Paste from workbook to another with criterias
Replies
2
Views
186
Anthony86
A
R
  • Solved
Overtime based on weekends AND holidays
2
Replies
12
Views
261
rockson
R
D
  • Question
Separate data and text from one cell to provide a duration with a summary
Replies
7
Views
314
BrerRabbit
B
J
  • Question
Conditional formatting based on value of another cell
Replies
3
Views
333
etaf
etaf
P
  • Question
Need VBA to automatically copy paste rows based on dates of current month.
2
Replies
11
Views
387
pk970
P

Forum statistics

Threads
1,216,107
Messages
6,128,866
Members
449,475
Latest member
Parik11

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top