Results 1 to 5 of 5
  1. #1
    Lounger
    Join Date
    Apr 2014
    Posts
    37
    Thanks
    2
    Thanked 1 Time in 1 Post

    Copy column from several excel files to one file - vba

    Hi,

    I'm trying to apply the below vba code to paste the data in columns (not in rows) but the values are being pasted all in the same column. So I only can see the result from the last file copied.

    I'm using:
    ---------------------
    Code:
    Option Explicit
    Sub CombineMultipleFiles()
    ' Path - modify as needed but keep trailing backslash
    Const sPath = "C:\MyPath\"
    
    Dim sFile As String
    Dim wbkSource As Workbook
    Dim wSource As Worksheet
    Dim wTarget As Worksheet
    Dim lColumns As Long
    Dim lMaxSourceColumn As Long
    Dim lMaxTargetColumn As Long
    'Dim blnNoHeader As Boolean
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Set wTarget = ActiveSheet
    lColumns = wTarget.Columns.Count
    sFile = Dir(sPath & "*.xlsx*")
    Do While Not sFile = ""
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
    Set wSource = wbkSource.Worksheets("1")
    lMaxSourceColumn = wSource.Cells(lColumns, 1).End(xlUp).Column
    lMaxTargetColumn = wTarget.Cells(lColumns, 1).End(xlUp).Column
    wSource.Range("B5:B8").Copy _
    Destination:=wTarget.Cells(lMaxTargetColumn + 1, 2) 'to start column B
    wbkSource.Close SaveChanges:=False
    sFile = Dir
    Loop
    
    ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
    
    ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
    End Sub
    ---------------------

    What I'm doing wrong?

    Many thanks

    LL
    Last edited by RetiredGeek; 2014-04-27 at 12:10. Reason: Added Code Tags

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Lucia,

    I think this is more what you are looking for if I understand what you are trying to do.

    Copy Column data from a series of workbooks into a new workbook using subsequent columns for each source?
    Code:
    Option Explicit
    
    Sub CombineMultipleFiles()
    
       ' Path - modify as needed but keep trailing backslash
       Const sPath = "C:\MYPath\"  'Of course I changed this for my test.
    
       Dim sFile            As String
       Dim wbkSource        As Workbook
       Dim wSource          As Worksheet
       Dim wTarget          As Worksheet
       Dim lColumns         As Long
       Dim lMaxSourceColumn As Long
       Dim lMaxTargetColumn As Long
       Dim lCopyRow         As Long
    
       lCopyRow = 6    'Set to Row where you want the first item in the column to be
    
    'Dim blnNoHeader As Boolean
    
       On Error GoTo ErrHandler
       Application.ScreenUpdating = False
    
       Set wTarget = ActiveSheet
       lColumns = wTarget.Columns.Count
       sFile = Dir(sPath & "*.xls*")
    
       Do While Not sFile = ""
         Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
         Set wSource = wbkSource.Sheets(1)
         lMaxSourceColumn = wSource.Cells(5, lColumns).End(xlToLeft).Column
         lMaxTargetColumn = wTarget.Cells(lCopyRow, lColumns).End(xlToLeft).Column
         wSource.Range("B5:B8").Copy _
             Destination:=wTarget.Cells(lCopyRow, lMaxTargetColumn + 1) 'to start column B
         wbkSource.Close SaveChanges:=False
         sFile = Dir()
       Loop
    
    ExitHandler:
       Application.ScreenUpdating = True
       Exit Sub
    
    ErrHandler:
       MsgBox Err.Description, vbExclamation
       Resume ExitHandler
    End Sub
    I think you have the CELLS() function backwards it should be Cells(Row Reference, Column Reference).

    Here's the output from my test files. Note the 1st 5 rows were put there to make sure I didn't overwrite data that may exist on the destination sheet please reference the added variable lCopyRow.
    ll.JPG
    Note: the ## are just because I didn't adjust the row width for large numbers. Also compare your code to mine as I made a couple of minor other minor.
    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. The Following User Says Thank You to RetiredGeek For This Useful Post:

    LuciaLourenco (2014-04-27)

  4. #3
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,823
    Thanks
    135
    Thanked 481 Times in 458 Posts
    Hi RG

    re "Note: the ## are just because I didn't adjust the row width for large numbers"

    I know you meant 'column width'. So how about adding something like this :

    Code:
    'We cannot just use an auto-column-fit because there may be wrapped text headings in the top
    'header row (and auto-fit would then give us a column too wide). So we increment the column
    'width by 2 and repeat until there are no futher ### cells displayed.
    
    Sub autoFixColumnWidths()                       'zeddy
    
    Dim zFoundCell As Range
    
    Set zFoundCell = [a1]                           'set initial start location
    
    Do Until zFoundCell Is Nothing                  'loop until no further ### found
    
    Set zFoundCell = Cells.Find(What:="###", _
            After:=zFoundCell, _
            LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, _
            SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    
    If Not zFoundCell Is Nothing Then                       'a cell displaying ### has been found
    zFoundCell.ColumnWidth = zFoundCell.ColumnWidth + 2     'increment column width by 2
    End If                                                  'end of test for found cell
    
    Loop                                            'repeat until no further ### found
    
    End Sub
    '***********************************************'********************************************
    zeddy
    Last edited by zeddy; 2014-04-27 at 15:15. Reason: typo

  5. #4
    Lounger
    Join Date
    Apr 2014
    Posts
    37
    Thanks
    2
    Thanked 1 Time in 1 Post
    Many, many thanks RG

  6. #5
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Zeddy,

    I'm gonna row row row my boat and come over there!

    Actually, I land at Heathrow on the 30th! We'll be visiting London & Brighton for 5 days then off to Scotland for a tour. Hunting for nessie!

    Thanks for the auto adjust COLUMN code!
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •