[已解决]EXCEL批量合并

福瑞安

请高手帮忙修改,谢谢!!


Sub Macro1()
    Dim filearr As Variant, j As Integer
    Dim rng As Range, i As Integer, sh As Worksheet
    ChDrive Left(ThisWorkbook.Path, 1)
    ChDir ThisWorkbook.Path
    filearr = Application.GetOpenFilename(filefilter:="Excel文件,*.xls", MultiSelect:=True)
    If IsArray(filearr) = False Then Exit Sub
    For j = 1 To UBound(filearr)
        With Workbooks.Open(filearr(j))
            Set sh = .Sheets("Sheet2") '新加
            For i = 1 To .Sheets.Count
                With .Sheets(i)
                    If .Name <> "Sheet2" Then
                        For Each rng In .Range("j18:j23")
                            If rng.Value = 4 Then
                              sh.Range("d27").Value = sh.Range("d27").Value + rng.Offset(0, 1).Value
                              rng.Offset(0, 0) = 0
                              rng.Offset(0, 1) = 0
                              rng.Offset(0, 3) = 0
                              rng.Offset(0, 4) = 0
                              rng.Offset(0, 5) = 3
                            End If
                        Next
                    End If
                End With
            Next
            .Close True
        End With
    Next
End Sub

最佳答案

月排行榜 / 总排行榜

zjdh

2012-8-11 20:03

若要序号6的那一行消除则修改：
ARR(i, 1) = “”
ARR(i, 2) = “”
更甚者是将后续行上提：

1. Sub Macro1()
   
2.     Dim filearr As Variant, j As Integer
   
3.     Dim F As Integer, i As Integer, sh As Worksheet, ARR
   
4.     ChDir ThisWorkbook.Path
   
5.     filearr = Application.GetOpenFilename(filefilter:="Excel文件,*.xls", MultiSelect:=True)
   
6.     If IsArray(filearr) = False Then Exit Sub
   
7.     For F = 1 To UBound(filearr)
   
8.         With Workbooks.Open(filearr(F))
   
9.             Set sh = .Sheets("Sheet1")
   
10.             If Not sh Is Nothing Then
    
11.                 ARR = sh.Range("j18:K23")
    
12.                 For i = 1 To UBound(ARR)
    
13.                     j=0
    
14.                     If ARR(i, 1) = 6 Then
    
15.                         For j = 1 To UBound(ARR)
    
16.                             If ARR(j, 1) = 4 Then
    
17.                                 ARR(j, 2) = ARR(j, 2) + ARR(i, 2)
    
18.                                 For k = i To UBound(ARR) - 1
    
19.                                   ARR(k, 1) = ARR(k + 1, 1)
    
20.                                   ARR(k, 2) = ARR(k + 1, 2)
    
21.                                 Next
    
22.                                 ARR(k, 1) = ""
    
23.                                 ARR(k, 2) = ""
    
24.                                 Exit For
    
25.                             End If
    
26.                         Next
    
27.                     End If
    
28.                     If j > UBound(ARR) Then ARR(i, 1) = 4: Exit For
    
29.                 Next
    
30.             sh.Range("j18:K23") = ARR
    
31.             .Close True
    
32.             End If
    
33.         End With
    
34.     Next
    
35. End Sub
    
36. 
    

复制代码

跳转到最佳答案楼层

zjdh

1. Sub Macro1()
   
2.     Dim filearr As Variant, j As Integer
   
3.     Dim F As Integer, i As Integer, sh As Worksheet, ARR
   
4.     ChDir ThisWorkbook.Path
   
5.     filearr = Application.GetOpenFilename(filefilter:="Excel文件,*.xls", MultiSelect:=True)
   
6.     If IsArray(filearr) = False Then Exit Sub
   
7.     For F = 1 To UBound(filearr)
   
8.         With Workbooks.Open(filearr(F))
   
9.             Set sh = .Sheets("Sheet1")
   
10.             If Not sh Is Nothing Then
    
11.                 ARR = sh.Range("J18:M23")
    
12.                 For i = 1 To UBound(ARR)
    
13.                     j = 0
    
14.                     If ARR(i, 1) = 6 Then
    
15.                         For j = 1 To UBound(ARR)
    
16.                             If ARR(j, 1) = 4 Then
    
17.                                 ARR(j, 2) = ARR(j, 2) + ARR(i, 2)
    
18.                                 ARR(i, 1) = 0
    
19.                                 ARR(i, 2) = 0
    
20.                                 ARR(i, 4) = 0
    
21.                                 Exit For
    
22.                             End If
    
23.                         Next
    
24.                     End If
    
25.                     If j > UBound(ARR) Then ARR(i, 1) = 4
    
26.                 Next
    
27.             sh.Range("J18:M23") = ARR
    
28.             .Close True
    
29.             End If
    
30.         End With
    
31.     Next
    
32. End Sub
    

复制代码

zjdh

1. Sub Macro1()
   
2.     Dim filearr As Variant, j As Integer
   
3.     Dim F As Integer, i As Integer, sh As Worksheet, ARR
   
4.     ChDir ThisWorkbook.Path
   
5.     filearr = Application.GetOpenFilename(filefilter:="Excel文件,*.xls", MultiSelect:=True)
   
6.     If IsArray(filearr) = False Then Exit Sub
   
7.     For F = 1 To UBound(filearr)
   
8.         With Workbooks.Open(filearr(F))
   
9.             Set sh = .Sheets("Sheet1")
   
10.             If Not sh Is Nothing Then
    
11.                 ARR = sh.Range("j18:K23")
    
12.                 For i = 1 To UBound(ARR)
    
13.                     If ARR(i, 1) = 6 Then
    
14.                         For j = 1 To UBound(ARR)
    
15.                             If ARR(j, 1) = 4 Then
    
16.                                 ARR(j, 2) = ARR(j, 2) + ARR(i, 2)
    
17.                                 ARR(i, 2) = 0
    
18.                                 Exit For
    
19.                             End If
    
20.                         Next
    
21.                     End If
    
22.                     If j > UBound(ARR) Then ARR(i, 1) = 4: Exit For
    
23.                 Next
    
24.             sh.Range("j18:K23") = ARR
    
25.             .Close True
    
26.             End If
    
27.         End With
    
28.     Next
    
29. End Sub
    

复制代码

福瑞安

zjdh 发表于 2012-8-11 08:43

首先非常感谢你的耐心解答,就是还差一点,序号6没有变为0,我的意思是序号6为0,然后序号6往右5小格都变为0,也就是相加后,序号6的那一行消除!

zjdh

福瑞安 发表于 2012-8-11 19:26
首先非常感谢你的耐心解答,就是还差一点,序号6没有变为0,我的意思是序号6为0,然后序号6往右5小格都变为0, ...

这容易啦，添加一句语句：
Sub Macro1()
    Dim filearr As Variant, j As Integer
    Dim F As Integer, i As Integer, sh As Worksheet, ARR
    ChDir ThisWorkbook.Path
    filearr = Application.GetOpenFilename(filefilter:="Excel文件,*.xls", MultiSelect:=True)
    If IsArray(filearr) = False Then Exit Sub
    For F = 1 To UBound(filearr)
        With Workbooks.Open(filearr(F))
            Set sh = .Sheets("Sheet1")
            If Not sh Is Nothing Then
                ARR = sh.Range("j18:K23")
                For i = 1 To UBound(ARR)
                    If ARR(i, 1) = 6 Then
                        For j = 1 To UBound(ARR)
                            If ARR(j, 1) = 4 Then
                                ARR(j, 2) = ARR(j, 2) + ARR(i, 2)
                                ARR(i, 1) = 0
                                ARR(i, 2) = 0
                                Exit For
                            End If
                        Next
                    End If
                    If j > UBound(ARR) Then ARR(i, 1) = 4: Exit For
                Next
            sh.Range("j18:K23") = ARR
            .Close True
            End If
        End With
    Next
End Sub

zjdh

若要序号6的那一行消除则修改：
ARR(i, 1) = “”
ARR(i, 2) = “”
更甚者是将后续行上提：

1. Sub Macro1()
   
2.     Dim filearr As Variant, j As Integer
   
3.     Dim F As Integer, i As Integer, sh As Worksheet, ARR
   
4.     ChDir ThisWorkbook.Path
   
5.     filearr = Application.GetOpenFilename(filefilter:="Excel文件,*.xls", MultiSelect:=True)
   
6.     If IsArray(filearr) = False Then Exit Sub
   
7.     For F = 1 To UBound(filearr)
   
8.         With Workbooks.Open(filearr(F))
   
9.             Set sh = .Sheets("Sheet1")
   
10.             If Not sh Is Nothing Then
    
11.                 ARR = sh.Range("j18:K23")
    
12.                 For i = 1 To UBound(ARR)
    
13.                     j=0
    
14.                     If ARR(i, 1) = 6 Then
    
15.                         For j = 1 To UBound(ARR)
    
16.                             If ARR(j, 1) = 4 Then
    
17.                                 ARR(j, 2) = ARR(j, 2) + ARR(i, 2)
    
18.                                 For k = i To UBound(ARR) - 1
    
19.                                   ARR(k, 1) = ARR(k + 1, 1)
    
20.                                   ARR(k, 2) = ARR(k + 1, 2)
    
21.                                 Next
    
22.                                 ARR(k, 1) = ""
    
23.                                 ARR(k, 2) = ""
    
24.                                 Exit For
    
25.                             End If
    
26.                         Next
    
27.                     End If
    
28.                     If j > UBound(ARR) Then ARR(i, 1) = 4: Exit For
    
29.                 Next
    
30.             sh.Range("j18:K23") = ARR
    
31.             .Close True
    
32.             End If
    
33.         End With
    
34.     Next
    
35. End Sub
    
36. 
    

复制代码

福瑞安

zjdh 发表于 2012-8-11 20:03
若要序号6的那一行消除则修改：
ARR(i, 1) = “”
ARR(i, 2) = “”

序号6没有全消除,能消除J,K列(也就是序号6和6后面对应的数)还有一个格的数字要消除,在M列!

福瑞安

还望高手再帮忙解答一下,不甚感激!!!!

福瑞安

zjdh 发表于 2012-8-11 19:38
这容易啦，添加一句语句：
Sub Macro1()
    Dim filearr As Variant, j As Integer

这个应该可以用了,序号6和6相对应的位置都显示0了,就是还有一个关键点,序号6和6相对应的位置分别在J,K列,而我在序号6相对应的M列还有一个数字也想变为0,不知如何编写?

zjdh

福瑞安 发表于 2012-8-12 07:12
这个应该可以用了,序号6和6相对应的位置都显示0了,就是还有一个关键点,序号6和6相对应的位置分别在J,K列, ...

还有啥要求一起说，别一点点的挤！

福瑞安

zjdh 发表于 2012-8-12 07:50
还有啥要求一起说，别一点点的挤！

没有了,谢谢了!!!