[已解决]多个excel文件的两个列求积

aiyuan704hi

如何将同一文件夹下，多个excel文件的两个列求积，并使所有的数据按照积所在列排序（计算结果不需要合并，保留在原excel即可），最后再将积列数据求和？
例如在文件夹下有多个excel 文件，需要批量将每一个excel文件的A列与B列相乘得到C列，最后数据按C列排序，再将C列数据求和，多谢！！！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-29 20:02

1. Sub Macro1()
   
2. Dim mypath$, wj$, arr, i&
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls*")
   
7. Do While wj <> ""
   
8.     If wj <> ThisWorkbook.Name Then
   
9.         s = 0
   
10.        With Workbooks.Open(mypath & wj)
    
11.             arr = Range("a1").CurrentRegion
    
12.             For i = 2 To UBound(arr)
    
13.                 arr(i, 4) = arr(i, 2) * arr(i, 3)
    
14.                 s = s + arr(i, 4)
    
15.             Next
    
16.             Range("d1").Resize(UBound(arr)) = Application.Index(arr, 0, 4)
    
17.             Range("a1").CurrentRegion.Sort [d2], Header:=xlGuess
    
18.             Cells(i, 4) = s
    
19.             .Close 1
    
20.        End With
    
21.     End If
    
22.     wj = Dir
    
23. Loop
    
24. MsgBox "OK"
    
25. Application.DisplayAlerts = True
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

跳转到最佳答案楼层

aiyuan704hi

多谢仁兄指点！欲文件夹中每个excel中的B列（价格）乘以C列（数量），得到D列数据（总金额），再使图表数据按照D列（总金额）升序排列，最后在D列（总金额）末端得到整个D列数据的加和。不知道有没有说清楚，还望各位仁兄大师不吝指教！

dsmch

1. Sub Macro1()
   
2. Dim mypath$, wj$, arr, i&
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls*")
   
7. Do While wj <> ""
   
8.     If wj <> ThisWorkbook.Name Then
   
9.         s = 0
   
10.        With Workbooks.Open(mypath & wj)
    
11.             arr = Range("a1").CurrentRegion
    
12.             For i = 2 To UBound(arr)
    
13.                 arr(i, 4) = arr(i, 2) * arr(i, 3)
    
14.                 s = s + arr(i, 4)
    
15.             Next
    
16.             Range("d1").Resize(UBound(arr)) = Application.Index(arr, 0, 4)
    
17.             Range("a1").CurrentRegion.Sort [d2], Header:=xlGuess
    
18.             Cells(i, 4) = s
    
19.             .Close 1
    
20.        End With
    
21.     End If
    
22.     wj = Dir
    
23. Loop
    
24. MsgBox "OK"
    
25. Application.DisplayAlerts = True
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

dsmch

………………

lmze2000

aiyuan704hi 发表于 2015-3-29 18:10
多谢仁兄指点！欲文件夹中每个excel中的B列（价格）乘以C列（数量），得到D列数据（总金额），再使图表数据 ...

1. Sub cal()
   
2.     Dim FileName$, Fn$, Mypath$, Sht As Worksheet, Wb As Workbook, Arr
   
3.     Application.DisplayAlerts = False
   
4.     Application.ScreenUpdating = False
   
5.     Mypath = ThisWorkbook.Path & ""
   
6.     FileName = Dir(Mypath & "*.xls*")
   
7.     Do While FileName <> ""
   
8.         If FileName <> ThisWorkbook.Name Then
   
9.             Fn = Mypath & FileName
   
10.             Set Wb = Workbooks.Open(Fn)
    
11.             Set Sht = Wb.Sheets(1)
    
12.             Arr = Sht.[a1].CurrentRegion
    
13.             ReDim brr(1 To UBound(Arr), 1 To 1)
    
14.             For i = 2 To UBound(Arr)
    
15.                 brr(i - 1, 1) = Arr(i, 2) * Arr(i, 3)
    
16.                 brr(UBound(Arr), 1) = brr(UBound(Arr), 1) + brr(i - 1, 1)
    
17.             Next
    
18.             [d2].Resize(UBound(brr)) = brr: Sht.Cells(UBound(brr) + 1, 1) = "合计"
    
19.             Sht.Sort.SortFields.Clear
    
20.             Sht.Sort.SortFields.Add Key:=Columns("d") _
    
21.                 , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
22.             With Sht.Sort
    
23.                 .SetRange [a1].CurrentRegion
    
24.                 .Header = xlYes
    
25.                 .MatchCase = False
    
26.                 .Orientation = xlTopToBottom
    
27.                 .SortMethod = xlPinYin
    
28.                 .Apply
    
29.             End With
    
30.             Wb.Close True
    
31.         End If
    
32.     FileName = Dir
    
33.     Loop
    
34.     Application.DisplayAlerts = True
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "合并完成"
    
37. End Sub
    
38. 
    

复制代码

aiyuan704hi

非常感谢各位大师，小弟拜谢！[em23]