hmmmidk220
12-20-2016, 03:06 PM
Hi!
What I need accomplished via VBA is:
1.) Grab selections of data from multiple sheets, put them in one sheet. This is around 450 rows.
2.) Of that consolidated data, delete any rows that have zero values (or very close to zero) in every column H through R. Note: the macro is set to delete these rows starting at row 500 and going up, the reason is because the sheet with all of the consolidated data has lookups at the bottom.
So I have two problems:
1.) My current macros will accomplish everything I want BUT since I have lookups at the bottom, the more times I run it, the more the distance between the data at the top and the lookups at the bottom, until eventually the 2nd macro won't run. I need this to be more automated than that. So is there a way to either clear the rows of data instead of deleting rows, or to add back in rows that are deleted, at the bottom of the raw data (but above the lookups at the bottom?)
2.) Is there a way to combine these macros into one?
Macro 1 which grabs data from sheets and puts it in the 'consol' sheet which has the lookups at the bottom:
Sub Consrev()
Worksheets("Consol").Range("A5:OZ500").ClearContents
Dim a As Integer 'beginning line of range of each sheet on the Consol pg
Dim B As Integer '# of lines of each sheet data to copy
Dim E As Integer '# of sheets
Dim F As String ' sheets to loop through
Dim G As Integer 'ending line of range of each sheet on the Consol pg
Dim H As Integer 'skip several lines down the Consol page at end of each sheet section
a = 5
For E = 1 To 12
F = Choose(E, "Sheet 1", "Sheet 2", "Sheet 3", "Sheet 4", "Sheet 5", "Sheet 6", "Sheet 7", "Sheet 8", "Sheet 9", "Sheet 10", "Sheet 11", "Sheet 12")
B = Choose(E, 27, 7, 19, 6, 17, 1, 3, 63, 23, 89, 144, 1) ' lines of data in each sheet (excl 1st row) - change this if rows expand
G = a + B
H = 3 + B
Range(Sheets("Consol").Cells(a, 1), Sheets("Consol").Cells(G, 20)) = Range(Sheets(F).Cells(3, 1), Sheets(F).Cells(H, 20)).Value
a = G + 2
Next E
End Sub
Macro 2 which deletes rows which have zero (or near zero) values in all of the chosen columns:
Public Sub DeleteZeroRows()Dim i As Long, lastrow As Long
'
'turn off screen updating and automatic calculation
'
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'
'find last row of data in column H
'
lastrow = Range("H" & Rows.Count).End(xlUp).Row
'
'start at the bottom row
'
For i = WorksheetFunction.Min(lastrow, 500) To 1 Step -1
'
'if the values in H to R are "nearly" zero then delete the row
'
If Evaluate("SumProduct(--(ABS(H" & i & ":R" & i & ")>.1))") = 0 Then
Rows(i).Delete
End If
Next i
'
'turn on screen updating and automatic calculation
'
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
Any ideas? I'm not looking to change macro 1 (unless it is to make it all one macro) but I think macro 2 needs to be changed to deal with the row creation problem.
Thanks!
What I need accomplished via VBA is:
1.) Grab selections of data from multiple sheets, put them in one sheet. This is around 450 rows.
2.) Of that consolidated data, delete any rows that have zero values (or very close to zero) in every column H through R. Note: the macro is set to delete these rows starting at row 500 and going up, the reason is because the sheet with all of the consolidated data has lookups at the bottom.
So I have two problems:
1.) My current macros will accomplish everything I want BUT since I have lookups at the bottom, the more times I run it, the more the distance between the data at the top and the lookups at the bottom, until eventually the 2nd macro won't run. I need this to be more automated than that. So is there a way to either clear the rows of data instead of deleting rows, or to add back in rows that are deleted, at the bottom of the raw data (but above the lookups at the bottom?)
2.) Is there a way to combine these macros into one?
Macro 1 which grabs data from sheets and puts it in the 'consol' sheet which has the lookups at the bottom:
Sub Consrev()
Worksheets("Consol").Range("A5:OZ500").ClearContents
Dim a As Integer 'beginning line of range of each sheet on the Consol pg
Dim B As Integer '# of lines of each sheet data to copy
Dim E As Integer '# of sheets
Dim F As String ' sheets to loop through
Dim G As Integer 'ending line of range of each sheet on the Consol pg
Dim H As Integer 'skip several lines down the Consol page at end of each sheet section
a = 5
For E = 1 To 12
F = Choose(E, "Sheet 1", "Sheet 2", "Sheet 3", "Sheet 4", "Sheet 5", "Sheet 6", "Sheet 7", "Sheet 8", "Sheet 9", "Sheet 10", "Sheet 11", "Sheet 12")
B = Choose(E, 27, 7, 19, 6, 17, 1, 3, 63, 23, 89, 144, 1) ' lines of data in each sheet (excl 1st row) - change this if rows expand
G = a + B
H = 3 + B
Range(Sheets("Consol").Cells(a, 1), Sheets("Consol").Cells(G, 20)) = Range(Sheets(F).Cells(3, 1), Sheets(F).Cells(H, 20)).Value
a = G + 2
Next E
End Sub
Macro 2 which deletes rows which have zero (or near zero) values in all of the chosen columns:
Public Sub DeleteZeroRows()Dim i As Long, lastrow As Long
'
'turn off screen updating and automatic calculation
'
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'
'find last row of data in column H
'
lastrow = Range("H" & Rows.Count).End(xlUp).Row
'
'start at the bottom row
'
For i = WorksheetFunction.Min(lastrow, 500) To 1 Step -1
'
'if the values in H to R are "nearly" zero then delete the row
'
If Evaluate("SumProduct(--(ABS(H" & i & ":R" & i & ")>.1))") = 0 Then
Rows(i).Delete
End If
Next i
'
'turn on screen updating and automatic calculation
'
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
Any ideas? I'm not looking to change macro 1 (unless it is to make it all one macro) but I think macro 2 needs to be changed to deal with the row creation problem.
Thanks!