提取店名，并根据店名求和

chenbenhai · 发表于 2019-1-11 11:55

LMY123 发表于 2019-1-11 11:26

谢谢，我研究一下

cjc209 · 发表于 2019-1-11 12:00

LMY123 发表于 2019-1-11 11:26

你的代码你测试过吗？根本不能运行你怎么又变成初级了以前你的帖子数为5000多啊你完全是灌水惯出来的没有看到你有多少实际能用的代码

chenbenhai · 发表于 2019-1-11 12:03

到这 [al].Resize(n, 4) = Arr 提示要求对象运行是错误424

thymethy · 发表于 2019-1-11 12:14

Sub ts()
Dim d As Object, arr, brr(), i%, j%, f$, wb As Workbook, n%, m%, rng As Range, x%
Set d = CreateObject("scripting.dictionary")
f = Dir(ThisWorkbook.Path & "\*.xl*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f)
For Each rng In wb.Sheets(1).Range([a1], wb.Sheets(1).Cells(1, Columns.Count).End(xlToLeft))
If rng <> "????????" And rng <> "????" And rng <> "????" And rng <> "???" Then
rng.EntireColumn.Delete
End If
Next
arr = wb.Sheets(1).[a1].CurrentRegion
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
n = n + 1
d(arr(i, 1)) = n
ReDim Preserve brr(1 To 4, 1 To n)
For j = 1 To UBound(arr, 2)
brr(j, n) = arr(i, j)
Next
Else
m = d(arr(i, 1))
For x = 3 To UBound(arr, 2)
brr(x, m) = brr(x, m) + arr(i, x)
Next
End If
Next
wb.Close False
End If
f = Dir
Loop
ThisWorkbook.Sheets(1).UsedRange.Offset(1).ClearContents
ThisWorkbook.Sheets(1).[a2].Resize(n, 4) = Application.Transpose(brr)
End Sub

复制代码

cjc209 · 发表于 2019-1-11 12:41

LMY123 发表于 2019-1-11 11:26

你自己测试过你写的代码吗

chenbenhai · 发表于 2019-1-11 12:50

我水平差，一个都运行不了

chenbenhai · 发表于 2019-1-11 12:53

thymethy 发表于 2019-1-11 12:14

谢谢，运行到ThisWorkbook.Sheets(1).[a2].Resize(n, 4) = Application.Transpose(brr)
错误代码5，无效的过程调用或参数

chenbenhai · 发表于 2019-1-11 13:05

三位给出代码的大侠能按我的附件给到我吗，我好好学习一下。

thymethy · 发表于 2019-1-11 13:09

附上附件

chenbenhai · 发表于 2019-1-11 13:44

thymethy 发表于 2019-1-11 13:09
附上附件

多谢您了，十分感谢

		自动登录	找回密码
密码			免费注册

[求助] 提取店名，并根据店名求和