[已解决]合并数据遇到的问题

张雄友

合并数据遇到的问题，出错。

1. Sub 不等列合并()
   
2.     Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction '定义100万行，30列。
   
3.     Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         MyPath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     'On Error GoTo 100
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     n = 1
    
13.     Set w = Application.WorksheetFunction
    
14.     MyName = Dir(MyPath & "*.xls*")
    
15.     Do While MyName <> ""
    
16.         If MyName <> ThisWorkbook.Name Then
    
17.             With GetObject(MyPath & MyName)
    
18.                 For Each sh In .Worksheets
    
19.                     If w.CountA(sh.UsedRange) Then
    
20.                         Set c = sh.UsedRange
    
21.                         arr = c.Resize(sh.Cells(sh.Rows.Count, c.Column).End(xlUp).Row - c.Row + 1, c.Offset(, sh.Columns.Count - c.Column).End(xlToLeft).Column)
    
22.                         For j = 1 To UBound(arr, 2)
    
23.                             If Len(arr(1, j)) Then
    
24.                                 If Not d.Exists(arr(1, j)) Then
    
25.                                     n = n + 1
    
26.                                     d(arr(1, j)) = n
    
27.                                     brr(0, n) = arr(1, j)
    
28.                                 End If
    
29.                             End If
    
30.                         Next
    
31.                         For i = 2 To UBound(arr)
    
32.                             m = m + 1
    
33.                             If m > 1048575 Then
    
34.                                 MsgBox "超出最大行数1048576，无法合并"
    
35.                                 Exit Sub
    
36.                             End If
    
37.                             brr(m, 1) = arr(i, 1)
    
38.                             brr(m, 0) = sh.Name '表名
    
39.                             For j = 2 To UBound(arr, 2)
    
40.                                 If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
    
41.                             Next
    
42.                         Next
    
43.                     End If
    
44.                 Next
    
45.                 .Close False
    
46.             End With
    
47.         End If
    
48.         MyName = Dir
    
49.     Loop
    
50.     Application.ScreenUpdating = True
    
51.     Cells.ClearContents
    
52.     brr(0, 0) = "表名" '表名
    
53.     If m Then [A1].Resize(m + 1, n + 1) = brr
    
54. '100:
    
55. End Sub
    

复制代码

最佳答案

月排行榜 / 总排行榜

xdragon

2014-11-14 22:18

张雄友 发表于 2014-11-14 21:46
这个 UsedRange 定位不全啊，像工作簿《0》中工作表《sheet1》中的，2.2 ，都没有合并到。

难道是这句 ...

实际上表格定位没有绝对全的
这个判断也很复杂了，考虑的也挺全面，不过他还是从已用区域的第一个行和第一列判断的。
如果你要改，就你那个例子来说用 arr=c.value 可能是更加准确一点。

跳转到最佳答案楼层

xdragon

Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction '定义100万行，30列。
    Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False
    'On Error GoTo 100
    Set d = CreateObject("scripting.dictionary")
    Set w = Application.WorksheetFunction
    MyName = Dir(MyPath & "*.xls*")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sh In .Worksheets
                    If w.CountA(sh.UsedRange) Then
                        Set c = sh.UsedRange
                        arr = c.Resize(sh.Cells(sh.Rows.Count, c.Column).End(xlUp).Row - c.Row + 1, c(1, 1).Offset(, sh.Columns.Count - c.Column).End(xlToLeft).Column)
                        For j = 1 To UBound(arr, 2)
                            If Len(arr(1, j)) Then
                                If Not d.Exists(arr(1, j)) Then
                                    d(arr(1, j)) = n
                                    brr(0, n) = arr(1, j)
                                    n = n + 1
                                End If
                            End If
                        Next
                        For i = 2 To UBound(arr)
                            m = m + 1
                            If m > 1048575 Then
                                MsgBox "超出最大行数1048576，无法合并"
                                Exit Sub
                            End If
                            brr(m, 1) = arr(i, 1)
                            brr(m, 0) = sh.Name '表名
                            For j = 2 To UBound(arr, 2)
                                If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                            Next
                        Next
                    End If
                Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    Cells.ClearContents
    brr(0, 0) = "表名" '表名
    If m Then [A1].Resize(m + 1, n + 1) = brr
'100:
End Sub

改动部分我做了红色的标识，你看看，另外n=1（12行）我也删了。表名在第一列，和你效果的貌似有点不一样，不过你运行下应该能自己换吧？

张雄友

xdragon 发表于 2014-11-14 20:08
Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction ' ...

表名在前在后无所谓，但是明年计划怎么合并在工号下面了？？

xdragon

Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction '定义100万行，30列。
    Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False
    'On Error GoTo 100
    Set d = CreateObject("scripting.dictionary")
    Set w = Application.WorksheetFunction
    MyName = Dir(MyPath & "*.xls*")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sh In .Worksheets
                    If w.CountA(sh.UsedRange) Then
                        Set c = sh.UsedRange
                        arr = c.Resize(sh.Cells(sh.Rows.Count, c.Column).End(xlUp).Row - c.Row + 1, c(1, 1).Offset(, sh.Columns.Count - c.Column).End(xlToLeft).Column)
                        For j = 1 To UBound(arr, 2)
                            If Len(arr(1, j)) Then
                                If Not d.Exists(arr(1, j)) Then
                                    d(arr(1, j)) = n
                                    brr(0, n) = arr(1, j)
                                    n = n + 1
                                End If
                            End If
                        Next
                        For i = 2 To UBound(arr)
                            m = m + 1
                            If m > 1048575 Then
                                MsgBox "超出最大行数1048576，无法合并"
                                Exit Sub
                            End If
                            brr(m, d(arr(1, 1))) = arr(i, 1)
                            brr(m, 0) = sh.Name '表名
                            For j = 2 To UBound(arr, 2)
                                If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                            Next
                        Next
                    End If
                Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    Cells.ClearContents
    brr(0, 0) = "表名" '表名
    If m Then [A1].Resize(m + 1, n + 1) = brr
'100:
End Sub

一样还是用红色标注了。。。

张雄友

xdragon 发表于 2014-11-14 20:53
Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction ' ...

答案不对的。换了数据源就会发现。工作簿《1》中的，工作表《sheet1》中的，

aa

1

都没有合并到。

张雄友

xdragon 发表于 2014-11-14 20:53
Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction ' ...

用1楼和 3楼的 附件测试同样，合并后，日期这列都不见了。

xdragon

张雄友 发表于 2014-11-14 21:25
用1楼和 3楼的 附件测试同样，合并后，日期这列都不见了。

Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFunction '定义100万行，30列。
    Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False
    'On Error GoTo 100
    Set d = CreateObject("scripting.dictionary")
    Set w = Application.WorksheetFunction
    MyName = Dir(MyPath & "*.xls*")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sh In .Worksheets
                    If w.CountA(sh.UsedRange) Then
                        Set c = sh.UsedRange
                        arr = c.Resize(sh.Cells(sh.Rows.Count, c.Column).End(xlUp).Row - c.Row + 1, c(1, 1).Offset(, sh.Columns.Count - c.Column).End(xlToLeft).Column)
                        For j = 1 To UBound(arr, 2)
                            If Len(arr(1, j)) Then
                                If Not d.Exists(arr(1, j)) Then
                                    n = n + 1
                                    d(arr(1, j)) = n
                                    brr(0, n) = arr(1, j)
                                End If
                            End If
                        Next
                        For i = 2 To UBound(arr)
                            m = m + 1
                            If m > 1048575 Then
                                MsgBox "超出最大行数1048576，无法合并"
                                Exit Sub
                            End If
                            brr(m, d(arr(1, 1))) = arr(i, 1)
                            brr(m, 0) = sh.Name '表名
                            For j = 2 To UBound(arr, 2)
                                If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                            Next
                        Next
                    End If
                Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    Cells.ClearContents
    brr(0, 0) = "表名" '表名
    If m Then [A1].Resize(m + 1, n + 1) = brr
'100:
End Sub

其实你只要逐步运行就能看出来端倪了 ，发现一个错误改一次，你的这个代码就有三个明显的错误，(*^__^*) 嘻嘻

张雄友

xdragon 发表于 2014-11-14 21:33
Sub 不等列合并()
    Dim sh As Worksheet, arr, brr(0 To 1000000, 0 To 30), w As WorksheetFuncti ...

这个 UsedRange 定位不全啊，像工作簿《0》中工作表《sheet1》中的，2.2 ，都没有合并到。

难道是这句？                       arr = c.Resize(sh.Cells(sh.Rows.Count, c.Column).End(xlUp).Row - c.Row + 1, c(1, 1).Offset(, sh.Columns.Count - c.Column).End(xlToLeft).Column)

xdragon

张雄友 发表于 2014-11-14 21:46
这个 UsedRange 定位不全啊，像工作簿《0》中工作表《sheet1》中的，2.2 ，都没有合并到。

难道是这句 ...

实际上表格定位没有绝对全的
这个判断也很复杂了，考虑的也挺全面，不过他还是从已用区域的第一个行和第一列判断的。
如果你要改，就你那个例子来说用 arr=c.value 可能是更加准确一点。

张雄友

xdragon 发表于 2014-11-14 22:18
实际上表格定位没有绝对全的
这个判断也很复杂了，考虑的也挺全面，不过他还是从已用区域的第一个行 ...

谢谢大龙，我再看看。