CODEWITHSUNDEEP
excelexcel-2010vba
user1477371
user1477371

Reputation: 23

Copy rows from multiple worksheets based on number value

I have a multiple sales worksheets where the salesmen put among other things, their confidence level for a certain sale. I have just started learning VBA, so I am not clueless but I have to admit this is over my head.

If a row has a confidence level over 60%, I want the entire row copied to a new worksheet.

The data begins on row 8 and the confidence percentage column is column V.

There are a total of 9 worksheets I want the VBA script to be applied to, they are named:

I want all the rows with a confidence level over 60% copied over to a master or "Install" sheet, beginning once again on row 8. I want to run the script by a button on the "Install" sheet.

Here is a picture of what I am working with:

excel

Upvotes: 2

Views: 2351

Answers (1)

brettdj
brettdj

Reputation: 55692

The code below

  • copies rows 8 down from all your nine sheets (if the names exists) to a sheet called "Install"
  • any records less than 60% are autofiltered and deleted from the master sheets (more efficient than autofiltering each of the nine sheets before copying)
  • blanks rows are added at the top to start "Install" at row 8

*If you do need header rows from row 1 to 7 then these can be copied from one of the salesman sheets - let me know *

Sub QuickCombine()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim strShts()
Dim strWs As Variant
Dim lngCalc As Long

With Application
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With

Set ws1 = Sheets("Install")
ws1.UsedRange.Cells.Clear

strShts = Array("Jeff", "John", "Tim", "Pete", "Chad", "Bob", "Kevin", "Mike", "Bill")
For Each strWs In strShts
On Error Resume Next
Set ws2 = Sheets(strWs)
On Error GoTo 0
If Not ws2 Is Nothing Then
Set rng1 = ws2.Range(ws2.[v8], ws2.Cells(Rows.Count, "v").End(xlUp))
rng1.EntireRow.Copy ws1.Cells(ws1.Cells(Rows.Count, "v").End(xlUp).Offset(1, 0).Row, "A")
End If
Set ws2 = Nothing
Next
With ws1
    .[v1] = "dummy"
    .Columns("V").AutoFilter Field:=1, Criteria1:="<60%"
    .Rows.Delete
.Rows("1:7").Insert
End With
With Application
.ScreenUpdating = True
.Calculation = lngCalc
End With
End Sub

Upvotes: 1

Related Questions