Excel Forum

Code: Select all

Option Explicit
Sub CollectData()
    Dim ws As Worksheet
    Dim r As Range
    Dim rTarget As Range
    Dim ref
    Application.ScreenUpdating = False
    With Sheets("DB")
.UsedRange.ClearContents
.Range("A1:T1").Value = Array("WS", "Recipe", "Part Number", "Position", "FIDL", "Unit Name", "Class", "Pickup Count", "Total Parts Used", "Reject Parts", "No Pickup", "Error Parts", "Dislodged Parts", "Rescan Count", "LCR Check Used", "Pickup Rate", "Reject Rate", "Error Rate", "Dislodged Rate", "Success Rate")
End With
    For Each ws In Worksheets
        If ws.Name <> "DB" Then
            With Sheets("DB")
                Set rTarget = .Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
                 ref = Sheets("DB").Range("C" & Rows.Count).End(xlUp).Row
            End With         
            Set r = ws.Range("C14", ws.Range("T" & Rows.Count).End(xlUp).Offset(-1, 0))
                r.Copy
                rTarget.PasteSpecial xlPasteValues      
         Worksheets("DB").Range("A" & ref + 1, Range("B" & Rows.Count).End(xlUp).Offset(0, -1)) = ws.Name       
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Code: Select all

'Other code
With Sheets("DB")
     .UsedRange.ClearContents
     .Range("A1:T1").Value = Array("WS", "Recipe", "Part Number", "Position", "FIDL", "Unit Name", "Class", "Pickup Count", "Total Parts Used", "Reject Parts", "No Pickup", "Error Parts", "Dislodged Parts", "Rescan Count", "LCR Check Used", "Pickup Rate", "Reject Rate", "Error Rate", "Dislodged Rate", "Success Rate")
 End With
 For Each ws In Worksheets
     If ws.Name <> "DB" Then
         With Sheets("DB")
             Set rTarget = .Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
             ref = Sheets("DB").Range("C" & Rows.Count).End(xlUp).Row
         End With
         Set r = ws.Range("b13", ws.Range("T" & Rows.Count).End(xlUp).Offset(-1, 0))
         r.Copy
         rTarget.PasteSpecial xlPasteValues
      With Worksheets("DB")
         .Range("A" & ref + 1, .Range("C" & Rows.Count).End(xlUp).Offset(0, -2)) = ws.Name
         .Range("b" & ref + 1).Value = .Range("b" & ref + 2).Value
      End With
     End If
 Next ws
 With Sheets("DB")
     For Each r In .Range("b2", .Range("h" & .Rows.Count).End(xlUp).Offset(0, -6))
         If IsNumeric(r.Value) Or r.Value = "" Then
             r.Value = r.Offset(-1, 0).Value
         End If
     Next r
     .Range("c2", .Range("h" & .Rows.Count).End(xlUp).Offset(0, -5)) _
         .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 End With
'Other code