Macro to copy and paste solumns to new worksheet

fabrecass

New member
Joined
Feb 21, 2012
Messages
1
Reaction score
0
Points
0
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.

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
 
Back
Top