VBA code to copy Row labels

Question

Hello Microsoft Office Community,

I am working with an excel file that has 13 worksheets. The first twelve are labeled Jan through Dec. The last worksheet is a summary.

Each time the file is saved, a macro copies the data in colums A through K from each worksheet and pastes it into Colums D through N in the summary sheet. As sample of this code is provided below.

LastRow = Sheets("JAN").Cells(Rows.Count, 1).End(xlUp).RowSheets("Jan").Range("A12:k" & LastRow).Copy Sheets("summary").Range("d" & Rows.Count).End(xlUp)(2)

*LastRow = Sheets("FEB").Cells(Rows.Count, 1).End(xlUp).RowSheets("FEB").Range("A12:k" & LastRow).Copy Sheets("summary").Range("d" & Rows.Count).End(xlUp)(*2)

Each monthly  worksheet contain the name of the user in Cell A4, The office location in A6, and the month in A8. I would like to update the code provided above to enter this information into Colums A, B, and C of the summary sheet.

I struggle with VBA so any help I can get with this would be greratly appreciated.

Thank you.

Chris

Answer 1

I assume you cycle through all of the worksheets.  Here is some code that cycles through as you do in your lines above, and adds in the extra cells to copy.  It also adds some error checking in case one of the Monthly sheets is not present -- it will skip over that.

One possible limitation is that it only places the contents of A4:A6:A8 on the first line of the group of data coming from the Monthly sheet.  See below for a variation if you want this data on All of the lines.

The code also uses some techniques you may find useful as you learn more about VBA

=========================================

    Dim ws As Worksheet

    Dim wsSum As Worksheet

    Dim r As Range

    Dim MonthName As Variant

    Dim i As Long

MonthName = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

Set wsSum = Worksheets("Summary")

'don't know if next line needed UnComment if it is

'wsSum.Cells.Clear

For i = LBound(MonthName) To UBound(MonthName)

    On Error Resume Next

    Set ws = Worksheets(MonthName(i))

    Select Case Err.Number

        Case 0

            Set r = wsSum.Cells(Rows.Count, "D").End(xlUp)(2)

            ws.Range("A12", ws.Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=11).Copy r

            ws.Range("a4").Copy r.Offset(columnoffset:=-3)

            ws.Range("a6").Copy r.Offset(columnoffset:=-2)

            ws.Range("a8").Copy r.Offset(columnoffset:=-1)

        Case Is <> 9

            MsgBox ("Error " & Err.Number & vbTab & Err.Description)

            Exit Sub

    End Select

    On Error GoTo 0

Next i

================================

Variation to have A4:A6:A8 on each line of summary

=========================================

 Dim ws As Worksheet

    Dim wsSum As Worksheet

    Dim r1 As Range, r2 As Range

    Dim MonthName As Variant

    Dim v(0 To 2) As String

    Dim i As Long

MonthName = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

Set wsSum = Worksheets("Summary")

'don't know if next line needed  Uncomment if it is

'wsSum.Cells.Clear

For i = LBound(MonthName) To UBound(MonthName)

    On Error Resume Next

    Set ws = Worksheets(MonthName(i))

    Select Case Err.Number

        Case 0

          With ws

            Set r1 = wsSum.Cells(Rows.Count, "D").End(xlUp)(2)

            Set r2 = .Range("A12", .Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=11)

            r2.Copy Destination:=r1

            v(0) = .[a4]: v(1) = .[a6]: v(2) = .[a8]

            Set r1 = r1.Offset(columnoffset:=-3).Resize(rowsize:=r2.Rows.Count, columnsize:=3)

            r1 = v

        End With

        Case Is <> 9  '9 will be error if worksheet not present; so ignore it

            MsgBox ("Error " & Err.Number & vbTab & Err.Description)

            Exit Sub

    End Select

    On Error GoTo 0

Next i

Answer 2

You are welcome.

Answer 3

Ron,

This worked like a charm. Thank you so much. I appreciate your time and value your efforts.

CVhris

Answer 4

Ashish,

Your solution was very helpful.

I appreciate your time and expertise.

Chris

Answer 5

Hi,

Try this

LastRow = Sheets("JAN").Cells(Rows.Count, 1).End(xlUp).RowSheets("Jan").Range("A12:k" & LastRow).Copy Sheets("summary").Range("d" & Rows.Count).End(xlUp)(2)

Sheets("Jan").Range("A4").Copy Sheets("summary").Range("A" & Rows.Count).End(xlUp)(2)

Sheets("Jan").Range("A6").Copy Sheets("summary").Range("B" & Rows.Count).End(xlUp)(2)

Sheets("Jan").Range("A8").Copy Sheets("summary").Range("C" & Rows.Count).End(xlUp)(2)

Hope this helps.