consolidate workbooks to pull particular columns

[pcorpz]

Hi Guys! The macro I am using works great. It consolidates all workbooks found in a folder. They all have the same header. What if, I only want certain columns pulled, instead of the whole header. I only want to pull columns B,G,H,I,L,N,O,Q,R,S,W,AF,AH, and AI? Can it be done?

 

[daniels012]

what is the Macro code you are using that works well now?

 

[pcorpz]

Option Explicit
Function PickFolder(strStartDir As Variant) As String
    Dim SA As Object, F As Object
    Set SA = CreateObject("Shell.application")
    Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
    If (Not F Is Nothing) Then
        PickFolder = F.items.Item.Path
    End If
    Set F = Nothing
    Set SA = Nothing
End Function

Sub CopySheetFromMultipleFiles()

    Dim lrow As Long
    Dim Hdrs As Long
    Dim NumCols As Long
    Dim ffc As Long
    Dim i As Long
    Dim R As Integer
    Dim WBn As String
    Dim rng As Range
    Dim WB As Workbook
    Dim WBr As Range
    Dim WBlstrw As Long
    Dim CurWks As Worksheet
    Dim CurWksLrow As Long
    Dim strStartDir As String
    Dim UserFile As String
    Dim Sht As Worksheet

    On Error Resume Next

    UserFile = PickFolder(strStartDir)
    If UserFile = "" Then
        MsgBox "Canceled"
        Exit Sub
    End If

    'CurWks will always refer to the Summary worksheet you are creating
    Set CurWks = ActiveWorkbook.Worksheets("Summary")

    Application.ScreenUpdating = False

    'Clear out the Summary worksheet
    CurWks.Activate
    With CurWks
        CurWksLrow = .Cells(Rows.Count, "A").End(xlUp).Row
        If CurWksLrow > 1 Then
            .Cells(2, 1).Resize(CurWksLrow - 1, 1).EntireRow.Delete
        End If
    End With

    lrow = 1
    Hdrs = 1
    With Application.FileSearch
        .SearchSubFolders = True
        .NewSearch
        .Filename = ".xls"
        .LookIn = UserFile
        .FileType = msoFileTypeExcelWorkbooks
        .Execute

        ffc = .FoundFiles.Count

        For i = 1 To ffc
            'WB will always refer to the source Workbook that you
            'are interrogating at the time

            Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i))
            
            If i = 1 Then
                NumCols = WB.Sheets(1).UsedRange.Column - 1 + _
                          WB.Sheets(1).UsedRange.Columns.Count
            End If

            Application.StatusBar = "Currently Processing file " & i & " of " & ffc

            WBn = WB.Name
            WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

            'Copy the data across
            CurWks.Cells(lrow + 1, "B").Resize(WBlstrw - Hdrs, NumCols).Value = _
            WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value

            'Put the filename in the first Col as an index value
            CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn
            lrow = lrow + (WBlstrw - Hdrs)

            WB.Close savechanges:=False
        Next
    End With

    Set WB = Nothing
    Set CurWks = Nothing

    Application.ScreenUpdating = True
    Application.StatusBar = False

End Sub