Hi guys,
need a macro to copy and paste columns A and B + columns headed "internal manufacturer's guarantee" and "manufacturer's guarantee" to a separate worksheet named "Summary".
My coding currently only copies and pastes column A and the other 2 columns, not column B
can anyone help? work restrictions mean i am unable to upload an attachment - but here's the coding i have.
need a macro to copy and paste columns A and B + columns headed "internal manufacturer's guarantee" and "manufacturer's guarantee" to a separate worksheet named "Summary".
My coding currently only copies and pastes column A and the other 2 columns, not column B
can anyone help? work restrictions mean i am unable to upload an attachment - but here's the coding i have.
Code:
Sub Manufacturersguarantee()
Dim internalmanufacturersguarantee As Variant
Dim Manufacturersguarantee As Variant
Dim DstRng As Range
Dim DstWks As Worksheet
Dim I As Long
Dim Info() As Variant
Dim N As Long
Dim R As Long
Dim Rng As Range
Dim Wks As Worksheet
Set DstWks = Worksheets("Summary")
Set DstRng = DstWks.Range("A2:C2")
DstWks.UsedRange.Offset(1, 0).ClearContents
For Each Wks In Worksheets
If Wks.Name <> DstWks.Name Then
Set Manufacturersguarantee = Wks.Rows(1).Find("manufacturer's guarantee", , xlValues, xlPart, xlByColumns, False)
If Not Manufacturersguarantee Is Nothing Then Manufacturersguarantee = Manufacturersguarantee.Column Else GoTo NextSheet
Set internalmanufacturersguarantee = Wks.Rows(1).Find("internal manufacturer's guarantee", , xlValues, xlPart, xlByColumns, False)
If Not internalmanufacturersguarantee Is Nothing Then internalmanufacturersguarantee = internalmanufacturersguarantee.Column Else GoTo NextSheet
ReDim Info(2, Wks.UsedRange.Rows.Count - 1)
For R = 2 To Wks.UsedRange.Rows.Count
If Wks.Cells(R, Manufacturersguarantee) <> "" Or Wks.Cells(R, internalmanufacturersguarantee) <> "" Then
Info(0, I) = Wks.Cells(R, 1)
Info(1, I) = Wks.Cells(R, Manufacturersguarantee)
Info(2, I) = Wks.Cells(R, internalmanufacturersguarantee)
I = I + 1
End If
Next R
DstRng.Offset(N, 0).Resize(I + 1, 3).Value = WorksheetFunction.Transpose(Info)
N = N + I
I = 0
End If
NextSheet:
Err.Clear
On Error GoTo 0
Next Wks
Set DstRng = DstRng.Resize(N, 3)
DstRng.Sort Key1:=DstRng.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub