Macro help

[Jemma Atkinson]

Hi, i need a macro that will copy pfolio and Totals <>0 to sheet2 range A12, (i dont require the headers to be copied), the totals column is not always in Column B it varies, so the macro needs to factor this in. When copying the totals over i need the code to round the totals to 2dp, if there is a 0.00 in sheet 2 then clear cell and move one cell up.

Excel Workbook
	A	B
9	pfolio	Total
10	KFGEEE	34
11	SDFSFF	0
12	ERWER	15
13	REGERG	0
Sheet1

Excel Workbook
	A	B
11	pfolio	Total
12	KFGEEE	34
13	ERWER	15
Sheet2

 

[Jemma Atkinson]

Hey Mark, i think there is With missing as i will be running this macro from Sheet 2

Sub MoveRowsToNewSheet()
'========================================================================
' COPIES ALL ROWS WHERE COLUMN WITH "Total" IN ROW 9 HAS VALUE NOT EQUAL TO 0
' FROM SHEET1 to A12 AND BELOW ON SHEET2
'========================================================================
    Dim LRMain As Long, LRNew As Long, i As Long, TotalCol As Long
 
    LRMain = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    TotalCol = Range("A9:AA9").Find("Total", Range("a9"), xlValues, xlWhole, xlByColumns, xlNext).Column
    With Worksheets("Sheet1")
        For i = 10 To LRMain Step 1
            Fred = Cells(i, TotalCol).Value
            If Cells(i, TotalCol).Value <> 0 Then
                LRNew = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
                If LRNew < 12 Then LRNew = 12
                Cells(i, 1).Copy Worksheets("Sheet2").Range("A" & LRNew + 1)
                Cells(i, TotalCol).Copy Worksheets("Sheet2").Range("b" & LRNew + 1)
            End If
        Next i
    End With
End Sub

The code above should now do what you want, I think

Please let me know how you get on

Mark

 

[Mark F]

Try

Sub MoveRowsToNewSheet()
'========================================================================
' COPIES ALL ROWS WHERE COLUMN WITH "Total" IN ROW 9 HAS VALUE NOT EQUAL TO 0
' FROM SHEET1 to A12 AND BELOW ON SHEET2
'========================================================================
    Dim LRMain As Long, LRNew As Long, i As Long, TotalCol As Long
    Worksheets("Sheet1").Select
    LRMain = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    TotalCol = Worksheets("Sheet1").Range("A9:AA9").Find("Total", Range("a9"), xlValues, xlWhole, xlByColumns, xlNext).Column
    With Worksheets("Sheet1")
        For i = 10 To LRMain Step 1
            If Cells(i, TotalCol).Value <> 0 Then
                LRNew = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
                If LRNew < 12 Then LRNew = 12
                Cells(i, 1).Copy Worksheets("Sheet2").Range("A" & LRNew + 1)
                Cells(i, TotalCol).Copy Worksheets("Sheet2").Range("b" & LRNew + 1)
            End If
        Next i
    End With
    Worksheets("Sheet2").Select
    Range("A" & Rows.Count).End(xlUp).Select
End Sub

 

[Jemma Atkinson]

Thanks Mark, works like a charm

Try

Sub MoveRowsToNewSheet()
'========================================================================
' COPIES ALL ROWS WHERE COLUMN WITH "Total" IN ROW 9 HAS VALUE NOT EQUAL TO 0
' FROM SHEET1 to A12 AND BELOW ON SHEET2
'========================================================================
    Dim LRMain As Long, LRNew As Long, i As Long, TotalCol As Long
    Worksheets("Sheet1").Select
    LRMain = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    TotalCol = Worksheets("Sheet1").Range("A9:AA9").Find("Total", Range("a9"), xlValues, xlWhole, xlByColumns, xlNext).Column
    With Worksheets("Sheet1")
        For i = 10 To LRMain Step 1
            If Cells(i, TotalCol).Value <> 0 Then
                LRNew = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
                If LRNew < 12 Then LRNew = 12
                Cells(i, 1).Copy Worksheets("Sheet2").Range("A" & LRNew + 1)
                Cells(i, TotalCol).Copy Worksheets("Sheet2").Range("b" & LRNew + 1)
            End If
        Next i
    End With
    Worksheets("Sheet2").Select
    Range("A" & Rows.Count).End(xlUp).Select
End Sub

 

[Mark F]

My pleasure!

Little bit more of a challenge than I anticipated as to start with you hadn't mentioned specifically and I hadn't noticed about the importance as it turned out of "Total" being in row 9

I also hadn't considered that you were going to run it from Sheet2

Worth then considering being very, very detailed and specific about what you are hoping for (bullet points?), as it does make it easier to assess whether you have the skills to help. If I am honest I wasn't sure I did have in this case - I am by no means an expert!

Still. Got there in the end! And very good learning for me!

All the best

Mark

 

[Jemma Atkinson]

Thanks Mark, just one last thing, in your code how can we paste special values so when the code copies to Sheet 2 the formulas can be copied over.

My pleasure!

Little bit more of a challenge than I anticipated as to start with you hadn't mentioned specifically and I hadn't noticed about the importance as it turned out of "Total" being in row 9

I also hadn't considered that you were going to run it from Sheet2

Worth then considering being very, very detailed and specific about what you are hoping for (bullet points?), as it does make it easier to assess whether you have the skills to help. If I am honest I wasn't sure I did have in this case - I am by no means an expert!

Still. Got there in the end! And very good learning for me!

All the best

Mark

 

[Mark F]

Sub MoveRowsToNewSheet()
'========================================================================
' COPIES ALL ROWS WHERE COLUMN WITH "Total" IN ROW 9 HAS VALUE NOT EQUAL TO 0
' FROM SHEET1 to A12 AND BELOW ON SHEET2
'========================================================================
    Dim LRMain As Long, LRNew As Long, i As Long, TotalCol As Long
    Worksheets("Sheet1").Select
    LRMain = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    TotalCol = Worksheets("Sheet1").Range("A9:AA9").Find("Total", Range("a9"), xlValues, xlWhole, xlByColumns, xlNext).Column
    With Worksheets("Sheet1")
        For i = 10 To LRMain Step 1
            If Cells(i, TotalCol).Value <> 0 Then
                LRNew = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
                If LRNew < 12 Then LRNew = 12
    'Cells(i, 1).Copy Worksheets("Sheet2").Range("A" & LRNew + 1)
                Cells(i, 1).Copy
                Sheets("Sheet2").Range("A" & LRNew + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                                                              :=False, Transpose:=False
    'Cells(i, TotalCol).Copy Worksheets("Sheet2").Range("b" & LRNew + 1)
                Cells(i, TotalCol).Copy
                Sheets("Sheet2").Range("b" & LRNew + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                                                              :=False, Transpose:=False
            End If
        Next i
    End With
    Worksheets("Sheet2").Select
    Range("A" & Rows.Count).End(xlUp).Select
End Sub

Any good??

Mark

 

[Jemma Atkinson]

Thanks Mark, this works.

Sub MoveRowsToNewSheet()
'========================================================================
' COPIES ALL ROWS WHERE COLUMN WITH "Total" IN ROW 9 HAS VALUE NOT EQUAL TO 0
' FROM SHEET1 to A12 AND BELOW ON SHEET2
'========================================================================
    Dim LRMain As Long, LRNew As Long, i As Long, TotalCol As Long
    Worksheets("Sheet1").Select
    LRMain = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    TotalCol = Worksheets("Sheet1").Range("A9:AA9").Find("Total", Range("a9"), xlValues, xlWhole, xlByColumns, xlNext).Column
    With Worksheets("Sheet1")
        For i = 10 To LRMain Step 1
            If Cells(i, TotalCol).Value <> 0 Then
                LRNew = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
                If LRNew < 12 Then LRNew = 12
    'Cells(i, 1).Copy Worksheets("Sheet2").Range("A" & LRNew + 1)
                Cells(i, 1).Copy
                Sheets("Sheet2").Range("A" & LRNew + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                                                              :=False, Transpose:=False
    'Cells(i, TotalCol).Copy Worksheets("Sheet2").Range("b" & LRNew + 1)
                Cells(i, TotalCol).Copy
                Sheets("Sheet2").Range("b" & LRNew + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                                                              :=False, Transpose:=False
            End If
        Next i
    End With
    Worksheets("Sheet2").Select
    Range("A" & Rows.Count).End(xlUp).Select
End Sub

Any good??

Mark