copy non contiguous cells from multiple workbooks and paste horizontally in one workbook

[EmanY]

I'm a new Excel Macro user and need all I can get.

From multiple workbooks (source) (with same format), i need to copy multiple non contiguous cells ( say A2:A5, B1, C3, D8:D10) and paste them horizontally on another workbook (destination) starting at cell A6. Then need to do the same for the next workbook (source) and paste on the next blank row in the destination workbook.

Thanks

 

[Leith Ross]

Hello EmanY,


This macro will Copy the cells "A2:A5, B1, C3, D8:D10" from each worksheet in each open workbook and paste the cell values horizontally in the destination workbook (the workbook running the macro) starting at cell "A6" and moving down. The macro will actually find the next empty row below "A6" if "A6" is not empty.

Sub Macro1A()

  ' Thread:  http://www.mrexcel.com/forum/showthread.php?t=581080
  ' Poster:  EmanY
  ' Written: September 22, 2011
  ' Author:  Leith Ross
  
    Dim Cell As Range
    Dim Data As Variant
    Dim DstRng As Range
    Dim DstSht As Worksheet
    Dim N As Long
    Dim R As Long
    Dim SrcRng As Range
    Dim SrcData As Variant
    Dim SrcWkb As Workbook
    Dim SrcWks As Worksheet
    
    
        Set DstWks = Worksheets("Sheet1")
        
        Set DstRng = DstWks.Range("A6")
        
            Set RngEnd = DstWks.Cells(Rows.Count, DstRng.Column).End(xlUp)
            
            If RngEnd.Row > DstRng.Row Then Set DstRng = DstWks.Range(DstRng, RngEnd.Offset(1, 0))
            
            
            For Each SrcWkb In Workbooks
        
                If SrcWkb.Name <> ThisWorkbook.Name Then
            
                   For Each SrcWks In SrcWkb.Worksheets
               
                       Set SrcRng = SrcWks.Range("A2:A5, B1, C3, D8:D10")
        
                       ReDim SrcData(Rng.Cells.Count - 1)
        
                       N = 0
        
                           For Each Cell In SrcRng
                               Data(N) = Cell.Value
                               N = N + 1
                           Next Cell
      
                       DstRng.Offset(R, 0).Resize(1, N).Value = SrcData
       
                       R = R + 1
                   
                   Next SrcWks
               
            End If
            
        Next SrcWkb
       
End Sub

 

[EmanY]

Thanks a lot Leith.

However, nothing happens when I run the macro. I was wondering how to get the source workbooks from a specified folder/location.

EmanY