title: Copying tables vertically arranged , from multiple files, and paste them horizontally into a master file
body: <p><strong>Source File</strong><br>
  <a href="https://i.stack.imgur.com/vFYkm.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/vFYkm.png" alt="Source File" /></a></p>
  <p><strong>Master/Target</strong><br>
  <a href="https://i.stack.imgur.com/99dNV.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/99dNV.png" alt="Master/Target file" /></a></p>
  <pre><code>    Sub Transfer_Reasons_decl()
  
      Const srcID As Variant = &quot;G. Reasons declnd &amp; wdrawn clms&quot; ' Name or Index e.g. &quot;Sheet1&quot; or 1
      Const srcAddr1 As String = &quot;B22:E26&quot;
      Const tgtID As Variant = &quot;Reasons declnd &amp; wdrawn clms&quot;  ' Name or Index e.g. &quot;Sheet1&quot; or 1
      Const tgtCol1 As Variant = 3              ' Number or String e.g. 1 or &quot;A&quot;
      Const Pattern As String = &quot;*.xlsx*&quot;
      
      Dim wbPath As String: wbPath = ThisWorkbook.Path &amp; Application.PathSeparator
      Dim tgt As Worksheet: Set tgt = ThisWorkbook.Worksheets(tgtID)
      
      
      Application.ScreenUpdating = False
      
      Dim wb As Workbook, src As Worksheet, tgtCell1 As Range
      Dim Source1 As Variant, Target1 As Variant                       ' Arrays
      Dim Val1 As Variant
      Dim i As Long, j As Long, l, m As Long, Name, Count As Long               ' Counters (Longs)
      Dim SrcRng As Range, TgtRng As Range
      
      
      Name = tgt.Cells(Rows.Count, 3).End(xlUp).Row
      
      Dim wbname As String: wbname = Dir(wbPath &amp; Pattern)
       Do Until wbname = &quot;&quot;
          If wbname &lt;&gt; ThisWorkbook.Name Then
          Name = Name + 1
          
      ThisWorkbook.Worksheets(&quot;Reasons declnd &amp; wdrawn clms&quot;).Cells(Name, 1) = wbname
      ThisWorkbook.Worksheets(&quot;Reasons declnd &amp; wdrawn clms&quot;).Cells(Name, 2) = FileDateTime(wbPath &amp; wbname)
          
          
          '******************************************************************
          
              GoSub readSource
              GoSub writeSource
              GoSub writeTarget
              
          End If
          
     WorksheetNotFound:
          wbname = Dir
      Loop
      
     Application.ScreenUpdating = True
     Application.CutCopyMode = False
      
     MsgBox &quot;Copied data from &quot; &amp; Count &amp; &quot; workbook(s)&quot;
    
     Exit Sub
  
     readSource:
      ' Write values from Source Range to Source Array.
      On Error Resume Next
      Set src = Workbooks.Open(wbPath &amp; wbname).Worksheets(srcID)
      Set src_B = Workbooks.Open(wbPath &amp; wbname).Worksheets(srcID_B)
      If Err.Number &lt;&gt; 0 Then GoTo closeSourceError
      On Error GoTo 0
      
      Source1 = src.Range(srcAddr1).Value
      src.Parent.Close False
        
      Return
      
      writeSource:
  
      ' Write values from Source Array to Target Array.
      'ReDim Target1(1 To 1, 1 To UBound(Source1) * UBound(Source1, 2))
       ReDim Target1(1 To UBound(Source1), 1 To UBound(Source1) * UBound(Source1, 2))
      '**************************************************
       l = 0
     
       For i = 1 To UBound(Source1)
       For j = 1 To UBound(Source1, 2)
                
       l = l + 1
      
       If IsEmpty(Source1(i, j)) Then
       Target1(i, j) = 0
      'Target1(m, l) = 0
       Else
       Target1(i, j) = Source1(i, j)
      'Target1(m, l) = Source1(i, j)
       End If
     
       Next j
       Next i
        
      
       Return
      
      writeTarget:
  
      ' Write values from Target Array to Target Range.
      
       Set tgtCell1 = tgt.Cells(tgt.UsedRange.Rows.Count, tgtCol1).End(xlUp).Offset(1)
       tgtCell1.Resize(, UBound(Source1, 2)).Value = Target1
       Count = Count + 1
       Return
      
  
       closeSourceError:
         src.Parent.Close False 
         On Error GoTo 0
         GoTo WorksheetNotFound
           
      End Sub
  </code></pre>