Extract columns and copy to separate worksheet

[AndyMcC]

I wish to copy the data from this table into seven separate worksheets. The numbers in Row 1 represent days of the week using the Weekday() function, and the seven worksheets contain data for each day of the week; the tabs at the bottom. In other words I want to extract all the data from columns with a 1 in Row 1 and paste them into the worksheet entitled Sunday, and so on. This is the XL2BB extract for the selected area in the screenshot.
I'm sure this is very simple but my VBA is a little rusty now that I'm retired.
Thanks

2023 Weeks 5 to 8.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1		1	2	3	4	5	6	7	1	2	3
2	Start time	29/01/23	30/01/23	31/01/23	01/02/23	02/02/23	03/02/23	04/02/23	05/02/23	06/02/23	07/02/23
3	00:00	0.305	0.39	0.32	0.517	0.121	0.08	0.12	0.147	0.307	0.233
4	00:30	0.326	0.077	0.45	0.076	0.449	0.115	0.126	0.349	0.322	0.194
5	01:00	0.089	0.557	0.096	0.523	0.163	0.365	0.075	0.153	0.089	0.385
6	01:30	0.539	0.08	0.527	0.089	0.317	0.219	0.096	0.11	0.672	0.186
7	02:00	0.09	0.338	0.125	0.389	0.217	0.157	0.249	0.102	0.068	0.633
8	02:30	0.428	0.254	0.537	0.233	0.221	0.124	0.282	0.53	0.313	0.143
9	03:00	0.383	0.105	0.238	0.317	0.354	0.47	0.269	0.184	0.287	0.5
10	03:30	0.101	0.505	0.54	0.313	0.119	0.079	0.091	0.075	0.071	0.244
11	04:00	0.522	0.088	0.128	0.173	0.469	0.09	0.346	0.456	0.521	0.402
12	04:30	0.073	0.182	0.496	0.452	0.081	0.487	0.186	0.125	0.129	0.368
13	05:00	0.311	0.446	0.132	0.131	0.488	0.077	0.102	0.164	0.427	0.354
14	05:30	0.35	0.07	0.259	0.541	0.09	0.084	0.119	0.395	0.293	0.526
15	06:00	0.28	0.392	0.422	0.089	0.252	0.512	0.531	0.108	0.252	0.306
16	06:30	0.643	0.28	0.491	0.651	0.302	0.092	0.325	0.75	0.393	0.552
17	07:00	0.498	0.53	0.668	0.354	0.15	0.684	0.512	0.288	0.471	0.464
18	07:30	0.413	0.488	0.205	0.734	0.467	0.173	0.335	0.658	0.509	0.652
19	08:00	0.471	0.18	0.513	0.067	0.157	0.392	0.115	0.107	0.107	0.293
20	08:30	0.275	0.405	0.035	0.067	0.322	0.189	0.545	0.347	0.184	0.401
21	09:00	0.35	0.026	0.08	0.057	0.346	0.007	0.062	0.036	0.033	0.243
22	09:30	0.073	0.146	0.141	0.041	0.207	0.124	0.194	0.002	0.006	0.436
23	10:00	0.168	0.003	0.276	0.016	0.198	0.026	0.243	0.033	0.003	0.297
24	10:30	0.658	0.048	0.321	0.389	0.206	0.495	0.73	0.101	0.105	0.02
25	11:00	0.013	0.005	0.017	0.028	0.354	0.007	0.011	0.009	0.007	0.87
26	11:30	0.501	0.003	0.844	0.007	0.205	0.003	0.026	0.324	0.007	0.3
27	12:00	1.886	0.003	1.879	0.003	0.065	0.004	0.006	2.196	0.005	0.005
28	12:30	0.918	0.004	0.305	0.004	0.079	0.004	0.004	1.727	0.004	0.003
Weeks 5 to 8

Cell Formulas
Range	Formula
B1:K1	B1	=WEEKDAY(B2)
C2:K2	C2	=B2+1

 

[rlv01]

One way.

Sub DoSomething()
    Dim WS As Worksheet
    Dim rngColData As Range, DestRange As Range
    Dim rngRowData As Range
    Dim R As Range
    Dim DayName As String
    
    Set WS = ActiveSheet
    With WS
        Set rngRowData = .Range("B1", .Cells(1, .Columns.Count).End(xlToLeft))
        
        For Each R In rngRowData
            Select Case R.Value
                Case 1
                    DayName = "Sunday"
                Case 2
                    DayName = "Monday"
                Case 3
                    DayName = "Tuesday"
                Case 4
                    DayName = "Wednesday"
                Case 5
                    DayName = "Thursday"
                Case 6
                    DayName = "Friday"
                Case 7
                    DayName = "Saturday"
                Case Else
                    DayName = ""
            End Select
            
            If DayName <> "" Then
                Set rngColData = .Range(.Cells(2, R.Column), .Cells(.Rows.Count, R.Column).End(xlUp))
                With Worksheets(DayName)
                    If .UsedRange.Cells.Count > 1 Then
                        Set DestRange = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1)
                    Else
                        Set DestRange = .Range("A1")
                    End If
                End With
                If Not (rngColData Is Nothing Or DestRange Is Nothing) Then
                    rngColData.Copy
                    DestRange.PasteSpecial xlPasteValuesAndNumberFormats
                    DestRange.Columns.AutoFit
                End If
                Set rngColData = Nothing
                Set DestRange = Nothing
            End If
        Next R
    End With
End Sub

 

[John_w]

Try this macro, which also copies the Start time column to column A in the destination sheets.

Public Sub Copy_Columns_To_Weekday_Sheets()

    Dim c As Long
    Dim destCell As Range
    
    With Worksheets("Weeks 5 to 8")
        For c = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            With Worksheets(Format(.Cells(2, c).Value, "dddd"))
                Set destCell = .Cells(1, .Columns.Count).End(xlToLeft)
                If Not IsEmpty(destCell.Value) Then Set destCell = destCell.Offset(, 1)
            End With
            If destCell.Column = 1 Then
                'Copy Start time column
                .Columns(1).Copy
                destCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                destCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Set destCell = destCell.Offset(, 1)
            End If
            'Copy date column
            .Columns(c).Copy
            destCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            destCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Next
    End With
   
    Application.CutCopyMode = False
   
End Sub

 

[AndyMcC]

One way.

Sub DoSomething()
    Dim WS As Worksheet
    Dim rngColData As Range, DestRange As Range
    Dim rngRowData As Range
    Dim R As Range
    Dim DayName As String
   
    Set WS = ActiveSheet
    With WS
        Set rngRowData = .Range("B1", .Cells(1, .Columns.Count).End(xlToLeft))
       
        For Each R In rngRowData
            Select Case R.Value
                Case 1
                    DayName = "Sunday"
                Case 2
                    DayName = "Monday"
                Case 3
                    DayName = "Tuesday"
                Case 4
                    DayName = "Wednesday"
                Case 5
                    DayName = "Thursday"
                Case 6
                    DayName = "Friday"
                Case 7
                    DayName = "Saturday"
                Case Else
                    DayName = ""
            End Select
           
            If DayName <> "" Then
                Set rngColData = .Range(.Cells(2, R.Column), .Cells(.Rows.Count, R.Column).End(xlUp))
                With Worksheets(DayName)
                    If .UsedRange.Cells.Count > 1 Then
                        Set DestRange = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1)
                    Else
                        Set DestRange = .Range("A1")
                    End If
                End With
                If Not (rngColData Is Nothing Or DestRange Is Nothing) Then
                    rngColData.Copy
                    DestRange.PasteSpecial xlPasteValuesAndNumberFormats
                    DestRange.Columns.AutoFit
                End If
                Set rngColData = Nothing
                Set DestRange = Nothing
            End If
        Next R
    End With
End Sub

Brilliant. Thanks, that works perfectly

 

[AndyMcC]

rlv01. Many thanks . That is brilliant. One small refinement if I could trouble you again. Before the macro starts the sorting and copying it needs to go to each of the "Day" pages and delete any previous data in columns B to E. That'll enable me to be able to rename the workbook and use it in the future.

 

[rlv01]

Why aren't you deleting column A as well?

 

[AndyMcC]

Why aren't you deleting column A as well?

Column A is the X-Axis of a chart derived from the data on each page. If the macro copies that from the the main worksheet then it can be deleted as well

 

[rlv01]

Then perhaps something like this

Sub ClearData()
    Dim WB As Workbook
    Dim WS As Worksheet

    Set WB = ThisWorkbook
    Set WS = ActiveSheet

    For Each WS In WB.Worksheets
        Select Case WS.Name
        Case "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"
         WS.UsedRange.Offset(0, 1).Cells.Clear
        End Select
   Next WS
End Sub

 

[AndyMcC]

Then perhaps something like this

Sub ClearData()
    Dim WB As Workbook
    Dim WS As Worksheet

    Set WB = ThisWorkbook
    Set WS = ActiveSheet

    For Each WS In WB.Worksheets
        Select Case WS.Name
        Case "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"
         WS.UsedRange.Offset(0, 1).Cells.Clear
        End Select
   Next WS
End Sub

 

[AndyMcC]

Thanks. That works a treat.