主题：Excel报表合并后横着排列

Sub HBSJ()  '合并指定目录中所有文件中相同格式工作表的数据
     Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer
   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   myPath = ThisWorkbook.Path & "\分表\"          '把文件路径定义给变量
  
   myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
   Do While myFile <> ""                     '当指定路径中有文件时进行循环
      If myFile <> ThisWorkbook.Name Then
         Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件
     
 
      For i = 1 To AK.Sheets.Count            '打开工作表
         aRow = AK.Sheets(i).Range("a65536").End(xlUp).row '打开的工作表A列总行数
         tRow = ThisWorkbook.Sheets("Sheet1").Range("b65536").End(xlUp).row + 1 '存货档案Sheet1数据行数
     
       If aRow > 1 Then
            'AK.Sheets(i).Select
        AK.Sheets(i).Range("a2:a" & aRow).Copy ThisWorkbook.Sheets("Sheet1").Range("b" & tRow)  '取得第3行a:f列以后的数据
        
        AK.Sheets(i).Range("b2:b" & aRow).Copy ThisWorkbook.Sheets("Sheet1").Range("g" & tRow)
      
        AK.Sheets(i).Range("c2:c" & aRow).Copy ThisWorkbook.Sheets("Sheet1").Range("i" & tRow)
      
         AK.Sheets(i).Range("d2:d" & aRow).Copy ThisWorkbook.Sheets("自定义").Range("h" & tRow)
        
         AK.Sheets(i).Range("e2:e" & aRow).Copy ThisWorkbook.Sheets("自定义").Range("i" & tRow)
        
         AK.Sheets(i).Range("f2:f" & aRow).Copy ThisWorkbook.Sheets("自定义").Range("l" & tRow)
       End If
        
      Next
        
        Workbooks(myFile).Close False               '关闭源工作簿,并不作修改
     
     
      End If
            
      MsgBox "正在导入" & myFile & "中数据", 64, "提示"
     
      myFile = Dir                                   '找寻下一个*.xls文件
   Loop
     
   Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用
   MsgBox "数据导入完成，请查看！", 64, "提示"

End Sub