VBA code to copy daily data to separate worksheets

[sj84]

Hi,

Apologies for a repeated question - I've found a bunch of similar questions, but I don't have solid enough VBA skills to be able to adapt to my specific query.

I have a single row summary table (TABLE 1), populated after various values are input across a related table (TABLE 2). Column A on TABLE 1 is a manually input date and various values go in columns B-H.

There are then separate tabs for each month. Each tab has a table the same as TABLE 1, except is has a row for each day of the month.

I need a macro that will copy values from TABLE 1 to the row corresponding with the date currently on TABLE 1, on the relevant month tab, and then leave it unchanged when a new date is input on TABLE 1 and the macro is run again.

Appreciate any help, thanks.

 

[Yongle]

Welcome to MrExcel

Table 1 and Table 2 assumed to be on separate sheets and that they are the only tables on those sheets
Monthly sheet names assumed to be Jan Feb Mar ...Dec
Run the code when cursor is on any cell in Table 1
Code assigns that row's values to a new row in the appropriate monthly sheet

Amend code below to match your monthly sheet names

Sub CopyValues()
    Dim wsMonth As Worksheet, dateCell As Range, copyThis As Range, pasteHere As Range, Tbl As ListObject
    On Error Resume Next
        Debug.Print ActiveCell.ListObject.Name
        If Err.Number > 0 Then
            MsgBox "active cell must be located inside table"
            Exit Sub
        End If
    On Error GoTo 0
    Set copyThis = Intersect(ActiveCell.EntireRow, ActiveSheet.ListObjects(1).Range)
    Set dateCell = copyThis.Cells(1, 1)
    Set wsMonth = Sheets(Format(copyThis.Cells(1, 1), "MMM"))
    Set Tbl = wsMonth.ListObjects(1)
'add row for latest values at end of table
    Tbl.ListRows.Add AlwaysInsert:=True
    Set pasteHere = Tbl.ListRows(Tbl.ListRows.Count).Range
'test to see if date already exists
    If WorksheetFunction.CountIf(Tbl.ListColumns(1).Range, dateCell) = 0 Then
        pasteHere.Value = copyThis.Value
    Else
        MsgBox dateCell & " already exists in " & Tbl.Parent.Name
    End If
End Sub

 

[sj84]

Welcome to MrExcel

Table 1 and Table 2 assumed to be on separate sheets and that they are the only tables on those sheets
Monthly sheet names assumed to be Jan Feb Mar ...Dec
Run the code when cursor is on any cell in Table 1
Code assigns that row's values to a new row in the appropriate monthly sheet

Amend code below to match your monthly sheet names

Sub CopyValues()
    Dim wsMonth As Worksheet, dateCell As Range, copyThis As Range, pasteHere As Range, Tbl As ListObject
    On Error Resume Next
        Debug.Print ActiveCell.ListObject.Name
        If Err.Number > 0 Then
            MsgBox "active cell must be located inside table"
            Exit Sub
        End If
    On Error GoTo 0
    Set copyThis = Intersect(ActiveCell.EntireRow, ActiveSheet.ListObjects(1).Range)
    Set dateCell = copyThis.Cells(1, 1)
    Set wsMonth = Sheets(Format(copyThis.Cells(1, 1), "MMM"))
    Set Tbl = wsMonth.ListObjects(1)
'add row for latest values at end of table
    Tbl.ListRows.Add AlwaysInsert:=True
    Set pasteHere = Tbl.ListRows(Tbl.ListRows.Count).Range
'test to see if date already exists
    If WorksheetFunction.CountIf(Tbl.ListColumns(1).Range, dateCell) = 0 Then
        pasteHere.Value = copyThis.Value
    Else
        MsgBox dateCell & " already exists in " & Tbl.Parent.Name
    End If
End Sub

Thanks very much for the reply. A couple of things I should have made clearer.

1. I shouldn't have used the word "TABLE", as while this is data presented as a table, none of it is formatted as an actual Excel table.

2. The month tabs contain other data / formatting where adding a row to the table may cause issues. Is there anything that can be done using a lookup so if the dates are already populated on the month tabs, then the corresponding data from what I originally labelled as "TABLE 1" can be copied across in the columns next to it?

 

[Yongle]

Ok - will post amended code when back at PC later today

Is this what you want?
- copy the values in chosen row (columns B:H) to B:H in month's sheet
- date lookup in column A determines row

 

[Yongle]

Data

Book1
	A	B	C	D	E	F	G	H
1	Date	Val1	Val2	Val3	Val4	Val5	Val6	Val7
2	01/01/2020	B2	C2	D2	E2	F2	G2	H2
3	02/01/2020	B3	C3	D3	E3	F3	G3	H3
4	03/01/2020	B4	C4	D4	E4	F4	G4	H4
5	04/01/2020	B5	C5	D5	E5	F5	G5	H5
6	05/01/2020	B6	C6	D6	E6	F6	G6	H6
7	06/01/2020	B7	C7	D7	E7	F7	G7	H7
8	07/01/2020	B8	C8	D8	E8	F8	G8	H8
9	08/01/2020	B9	C9	D9	E9	F9	G9	H9
10	09/01/2020	B10	C10	D10	E10	F10	G10	H10
11
Sheet1

Monthly Sheet - BEFORE

Book1
	A	B	C	D	E	F	G	H
1	Date	Val1	Val2	Val3	Val4	Val5	Val6	Val7
2	01/01/2020	B2	C2	D2	E2	F2	G2	H2
3	02/01/2020	B3	C3	D3	E3	F3	G3	H3
4	03/01/2020	B4	C4	D4	E4	F4	G4	H4
5	04/01/2020	B5	C5	D5	E5	F5	G5	H5
6	05/01/2020	B6	C6	D6	E6	F6	G6	H6
7	06/01/2020	B7	C7	D7	E7	F7	G7	H7
8	07/01/2020	B8	C8	D8	E8	F8	G8	H8
9	08/01/2020	B9	C9	D9	E9	F9	G9	H9
10	09/01/2020
11	10/01/2020
12	11/01/2020
13	12/01/2020
14	13/01/2020
15	14/01/2020
16	15/01/2020
17	16/01/2020
18	17/01/2020
Jan

Monthly Sheet - AFTER

Book1
	A	B	C	D	E	F	G	H
1	Date	Val1	Val2	Val3	Val4	Val5	Val6	Val7
2	01/01/2020	B2	C2	D2	E2	F2	G2	H2
3	02/01/2020	B3	C3	D3	E3	F3	G3	H3
4	03/01/2020	B4	C4	D4	E4	F4	G4	H4
5	04/01/2020	B5	C5	D5	E5	F5	G5	H5
6	05/01/2020	B6	C6	D6	E6	F6	G6	H6
7	06/01/2020	B7	C7	D7	E7	F7	G7	H7
8	07/01/2020	B8	C8	D8	E8	F8	G8	H8
9	08/01/2020	B9	C9	D9	E9	F9	G9	H9
10	09/01/2020	B10	C10	D10	E10	F10	G10	H10
11	10/01/2020
12	11/01/2020
13	12/01/2020
14	13/01/2020
15	14/01/2020
16	15/01/2020
17	16/01/2020
Jan

With active cell anywhere in correct row, run this code

Sub CopyValues()
    Dim WF As WorksheetFunction, wsMonth As Worksheet, Msg As String
    Dim dateCell As Range, lookHere As Range, pasteHere As Range, B_H As Range
    
    Set WF = Application.WorksheetFunction
    Set dateCell = Range("A" & ActiveCell.Row)
    Set B_H = dateCell.Offset(, 1).Resize(, 7)
    Set wsMonth = Sheets(Format(dateCell, "MMM"))
    Set lookHere = wsMonth.Range("A:A")

    If WF.CountIf(lookHere, dateCell) = 0 Then
        Msg = "OOPS!" & vbCr & dateCell & " Not Found"
    Else
        Set pasteHere = lookHere.Find(dateCell).Offset(, 1).Resize(, 7)
        If WF.CountBlank(pasteHere) = 7 Then
            pasteHere.Value = B_H.Value
            Msg = "OK"
        Else
            Msg = "OOPS!" & vbCr & dateCell & " already contains values"
        End If
    End If
    MsgBox Msg
    
End Sub

 

[Yongle]

I am no longer watching this thread