Home » excel » excel – Copying Rows based on Cell Values and then adding subtotals

excel – Copying Rows based on Cell Values and then adding subtotals

Posted by: admin May 14, 2020 Leave a comment

Questions:

I am fairly new to vba. Before I decided to post this question, I did some research and found a similar solution, but was unable to successfully implement the code. http://www.mrexcel.com/forum/excel-questions/715128-visual-basic-applications-copy-paste-entire-row-second-sheet-based-cell-value.html

I am on Microsoft Excel 2010 and windows 7. Basically, I am using an outside software to generate raw data into a blank workbook sheet called “Data.” I would like to copy the data from sheet “Data” and present it in a sheet called “Summary.” (I would like to add subtotals):

Using SQL server, I am bringing in column A as either “1” or “2.” The rows that have value “1” would be placed starting on row 6, column C of sheet “Summary.” The rows that have value “2” would start two rows after the first data set subtotals with the column titles. I would also like to exclude column A from the “Summary” Sheet. I have also included the code I started working on. I understand that the code I inserted is wrong, which is why I am posting this question:

Sub CopyData()

Dim lr As Long, lr2 As Long, r As Long

lr = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row

For r = lr To 2 Step -1
  If Range("A" & r).Value = "1" Then
    Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1)
    lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row
  End If
  If Range("A" & r).Value = "2" Then
    Rows(r).Copy Destination:=Sheets("Sheet1").Range("A" & lr2 + 1)
    lr3 = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
  End If
  Range("A1").Select
Next r

End Sub

Am I on the right track? Can someone please help?

How to&Answers:

Or .. a different approach
Sort the data first and autosense the last column with slightly shorter code

Sub CopyDatawithSort()

Dim sdRow As Long, sdCol As Long
Dim ssRow As Long, ssCol As Long

'data start r/c
sdRow = 2
sdCol = 1
'summary data start r/c
ssRow = 6
ssCol = 1

'last data row and column
ldrow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
ldCol = Sheets("Data").Cells(sdRow, Columns.Count).End(xlToLeft).Column

'sort data in order using column sdcol
Sheets("Data").Activate
    Sheets("Data").Range(Cells(sdRow, sdCol), Cells(ldrow, ldCol)).Select
    Selection.Sort Key1:=Columns(sdCol), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

'summary sheet column headers
    For r = 1 To ldCol
        Sheets("Summary").Cells(ssRow - 1, r).Value = "Col" & r
    Next r

'copy data
    Sheets("Data").Range(Cells(sdRow, sdCol), Cells(ldrow, ldCol)).Copy _
    Destination:=Sheets("Summary").Cells(ssRow, ssCol)

'subtotals
    Sheets("Summary").Activate
    Sheets("Summary").Cells(ssRow, ssCol).Select
    Selection.Subtotal GroupBy:=ssCol, Function:=xlSum, TotalList:=Array(2, 3, 4, 5, 6)

'clear Col 1
    Sheets("Summary").Columns(ssCol).ClearContents

End Sub

EDIT TO MEET ADDITIONAL Q

I’m not sure that you can remove the Grand Total using the Excel SubTotal function so you will need to remove it using code. Try the following:

Dim lsRow As Long
Dim gt As Range

and place the following code snippet before the ‘clear Col 1 line

'remove grandtotal
    lsRow = Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row
    Set gt = Range(Cells(ssRow, ssCol), Cells(lsRow, ssCol)).Find(After:=Cells(ssRow, ssCol), What:="Grand Total", LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows)
    gt.EntireRow.Clear

Answer:

Is your data sheet selected/activated when the macro runs? If not, then whatever sheet is active will be the sheet the data is being copied from. This line:

Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1)

… copies the row “r” from the active sheet. If you have “Summary” active so you can watch the magic happen then you are copying from “Summary” to “Summary”

So, either activate the “Data” sheet:

Sheets("Data").Activate

Or explicitly specify the sheet before the row:

Sheets("Data").Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1)

Edit:

In order to add a summary row for groupings by your column A you need to evaluate column A each loop to see if the next value is the same as the current one. If the next value is not the same then you need to insert a summary line. This also requires that you have a counter so you know how many rows must be summarized.

So, you need to include a line that counts the rows to group. So this:

If Range("A" & r).Value = "1" Then
  rowCount = rowCount + 1
  Sheets("Data").Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1)
  lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row
End If

And have a conditional statement inserts the summary line when the “group” is done:

If Range("A" & r).Value <> Range("A" & r - 1).Value Then
  'Do a bunch of stuff
End If

The “Do a bunch of stuff” depends on what you want to do. Maybe in column A you do nothing, column B you sum, column C you average. It depends on your preferences. For example, though:

Sheets("Summary").Range("A" & r).FormulaR1C1 = "=SUM(R[-" & rowCount & "]C:R[-1]C)" 

This can get very elaborate and is made more complicated by the fact that you are adding rows in one sheet, but not the other. I recommend that you play with this and if you need further help, pose a new question. Multi-part questions become messy to interpret. and there are many, many ways to approach your question.

Answer:

Try this.
I don’t think you can have gaps between your data sets to implement Excel subtotals and you will also need column headings. You can manually insert blank rows if you wish.
I have defined a row as noCols. To me, no point in copying over 16,000 cols if you are only using a few?
It is a good idea to structure your variables to give you a bit more flexibility in formatting once you get going (and if I have misread your spec!).
I’ll leave it to you to figure how to get whichever summary/total you require in col H from the output you have!
I have used some additional VBA statements which you can research yourself to take you forward.

Sub CopyData()


Dim lr As Long, lr2 As Long, lr3 As Long
Dim oneStartRow As Long
Dim startCol As Long
Dim noCols As Long
Dim rc As Long


oneStartRow = 6
startCol = 1
noCols = 33
rc = 0

lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row

'headings
    For r = 1 To noCols
        Sheets("Summary").Cells(oneStartRow - 1, r).Value = "Col" & r
    Next r

'dataset 1     
    For r = 2 To lr
        If Sheets("Data").Cells(r, 1).Value = "1" Then
            Sheets("Data").Cells(r, 1).Resize(1, noCols).Copy
            Sheets("Summary").Cells(oneStartRow + rc, startCol).Select
            ActiveSheet.Paste
            rc = rc + 1
        End If
    Next r

    lr3 = Sheets("Summary").Cells(Rows.Count, 2).End(xlUp).Row
    rc = 0

'dataset 2
    For r = 2 To lr
        If Sheets("Data").Cells(r, 1).Value = "2" Then
            Sheets("Data").Cells(r, 1).Resize(1, noCols).Copy
            Sheets("Summary").Cells(lr3 + rc, startCol).Select
            ActiveSheet.Paste
            rc = rc + 1
        End If
    Next r

'subtotals        
    Sheets("Summary").Cells(8, 1).Select  'Anywhere in data to be grouped
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3, 4, 5, 6)  'Array = Col no's to be summed

'clear col A
    Sheets("Summary").Columns(1).ClearContents 

End Sub