【求助】多表列字段合并，并且首两列排序不同的多表如何合并？

79051110

样表中，1-5这五个工作表，大致格式如表一和表二，求教大神怎么变成合并后的格式

表一						表二
区域	名称	Week1	Week2	Week3		区域	名称	Week4	Week5
华东	a	9	5	7		华东	c	3	4
华东	b	6	5	2		华东	b	3	0
华东	c	8	3	10		华东	a	5	0
华南	a	4	5	1		华南	b	3	4
华南	b	10	5	10		华南	a	10	9
合并后
区域	名称	Week1	Week2	Week3	Week4	Week5
华东	a	9	5	7	5	0
华东	b	6	5	2	3	0
华东	c	8	3	10	3	4
华南	a	4	5	1	10	9
华南	b	10	5	10	3	4

不知道为什么

如图，是你需要的效果？


代码供参考：

liulang0808

1. Sub test()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set sh = ThisWorkbook.Sheets(1)
   
4.     Application.ScreenUpdating = False
   
5.     Sheets(1).UsedRange.Offset(0, 2).ClearContents
   
6.     For j = 1 To 5
   
7.         pth = ThisWorkbook.Path & "" & j & ".xlsx"
   
8.         If fso.fileexists(pth) Then
   
9.             With Workbooks.Open(pth)
   
10.                 .Sheets(1).UsedRange.Offset(0, 2).Copy sh.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
    
11.                 .Close False
    
12.             End With
    
13.         End If
    
14.     Next j
    
15.     Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

一把小刀闯天下

'跟你的示例结果有点差别，你确定是正确的吗？

Option Explicit

Sub test()
  Dim arr, i, j, k, filename(), n, a, b, dic(1), t, key
  For i = 0 To UBound(dic): Set dic(i) = CreateObject("scripting.dictionary"): Next
  If Not getfilename(filename, ThisWorkbook.Path, ".xlsx") Then MsgBox "!": Exit Sub
  ReDim arr(1 To UBound(filename))
  a = 1: b = 2
  For i = 1 To UBound(filename)
    If filename(i) <> ThisWorkbook.FullName Then
      n = n + 1
      arr(n) = GetObject(filename(i)).Sheets("sheet1").[a1].CurrentRegion
      For j = 2 To UBound(arr(n), 1)
        t = arr(n)(j, 1) & arr(n)(j, 2)
        If Not dic(0).exists(t) Then a = a + 1: dic(0)(t) = a
      Next
      For j = 3 To UBound(arr(n), 2)
        If Not dic(1).exists(arr(n)(1, j)) Then b = b + 1: dic(1)(arr(n)(1, j)) = b
      Next
    End If
  Next
  ReDim brr(1 To dic(0).Count + 1, 1 To dic(1).Count + 2)
  For i = 1 To n
    For j = 2 To UBound(arr(i), 1)
      t = arr(i)(j, 1) & arr(i)(j, 2)
      brr(dic(0)(t), 1) = arr(i)(j, 1): brr(dic(0)(t), 2) = arr(i)(j, 2)
      For k = 3 To UBound(arr(i), 2)
        brr(dic(0)(t), dic(1)(arr(i)(1, k))) = arr(i)(j, k)
  Next k, j, i
  brr(1, 1) = "区域": brr(1, 2) = "名称": n = 2
  For Each key In dic(1).keys: n = n + 1: brr(1, n) = key: Next
  With Sheets("sheet1")
    .Cells.ClearContents
    .[a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  End With
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

79051110

感谢大家帮助，我先试用下

jjmysjg

liulang0808 发表于 2018-6-29 07:39
附件内容供参考。。。。。。

数据源的第1列和第2列数据没有汇总进来
麻烦老师看看

jjmysjg

不知道为什么 发表于 2018-6-29 02:13
如图，是你需要的效果？

大侠，能发个附件吗。
谢谢

zhangcheng6688

jjmysjg 发表于 2018-6-29 22:39
数据源的第1列和第2列数据没有汇总进来
麻烦老师看看

前面两列数据没有匹配过，直接合并了