[已解决]如何横向合并工作簿

songdg

前段时间得到大家的帮助解决了竖向合并工作簿的问题http://www.excelpx.com/thread-423218-1-1.html，再次表示感谢！现在又来了新问题，就是如何合并横向的工作簿，前两列作为表头。

最佳答案

月排行榜 / 总排行榜

dsmch

2016-8-18 05:43

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 20000, 1 To 200)
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls")
   
7. Application.ScreenUpdating = False
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.         s = s + 1
    
11.         With GetObject(mypath & wj)
    
12.             arr = .Sheets(1).Range("a1").CurrentRegion
    
13.             .Close 0
    
14.         End With
    
15.         lie = UBound(arr, 2)
    
16.         For i = 1 To UBound(arr)
    
17.             If Not d.exists(arr(i, 1)) Then
    
18.                 n = n + 1
    
19.                 d(arr(i, 1)) = n
    
20.                 For j = 1 To 2
    
21.                     brr(n, j) = arr(i, j)
    
22.                 Next
    
23.                 ss = s * (lie - 2) - 2
    
24.                 For j = 3 To lie
    
25.                     brr(n, ss + j) = arr(i, j)
    
26.                 Next
    
27.             Else
    
28.                 s2 = d(arr(i, 1))
    
29.                 ss = s * (lie - 2) - 2
    
30.                 For j = 3 To lie
    
31.                     brr(s2, ss + j) = arr(i, j)
    
32.                 Next
    
33.             End If
    
34.         Next
    
35.     End If
    
36.     wj = Dir
    
37. Loop
    
38. Range("a1").Resize(n, ss + j - 1) = brr
    
39. Application.ScreenUpdating = True
    
40. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 20000, 1 To 200)
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls")
   
7. Application.ScreenUpdating = False
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.         s = s + 1
    
11.         With GetObject(mypath & wj)
    
12.             arr = .Sheets(1).Range("a1").CurrentRegion
    
13.             .Close 0
    
14.         End With
    
15.         lie = UBound(arr, 2)
    
16.         For i = 1 To UBound(arr)
    
17.             If Not d.exists(arr(i, 1)) Then
    
18.                 n = n + 1
    
19.                 d(arr(i, 1)) = n
    
20.                 For j = 1 To 2
    
21.                     brr(n, j) = arr(i, j)
    
22.                 Next
    
23.                 ss = s * (lie - 2) - 2
    
24.                 For j = 3 To lie
    
25.                     brr(n, ss + j) = arr(i, j)
    
26.                 Next
    
27.             Else
    
28.                 s2 = d(arr(i, 1))
    
29.                 ss = s * (lie - 2) - 2
    
30.                 For j = 3 To lie
    
31.                     brr(s2, ss + j) = arr(i, j)
    
32.                 Next
    
33.             End If
    
34.         Next
    
35.     End If
    
36.     wj = Dir
    
37. Loop
    
38. Range("a1").Resize(n, ss + j - 1) = brr
    
39. Application.ScreenUpdating = True
    
40. End Sub

复制代码

songdg

dsmch 发表于 2016-8-18 05:43

谢谢但有个问题，我要保留前2列的表头该如何修改。

songdg

水平太差一时看不明白不知怎么改，等有时间再慢慢研究，不过还是要说一声谢谢。

fjnhwwx

试试这个,字典加数组运用

songdg

fjnhwwx 发表于 2016-9-6 21:42
试试这个,字典加数组运用

谢谢。其实这几个表格的行数和顺序是一样的，只需要简单的把后面几个表格的表头删除然后合并就行了，还有就是这几个表有不止一列的数据，麻烦帮忙再看看吧，在此先谢过了。

fjnhwwx

修改了下,是不是你相要的效果?

songdg

fjnhwwx 发表于 2016-9-7 12:47
修改了下,是不是你相要的效果?

非常感谢，宏很适用，还有就是如何修改才能保持原来的格式。

fjnhwwx

songdg 发表于 2016-9-7 14:35
非常感谢，宏很适用，还有就是如何修改才能保持原来的格式。

原来是什么格式，我看了下好像你没有设置什么格式

songdg

fjnhwwx 发表于 2016-9-7 22:07
原来是什么格式，我看了下好像你没有设置什么格式

嗯，这个附件是没格式的，但实际用到的有些包含格式的。我想能不能参考http://club.excelhome.net/thread-886774-1-1.html那样，把这几个表都复制过来然后删除重复的列，又或者第2、3个工作表只复制C列及之后的数据。