[已解决]关于工作表的名称问题

13724841877 · 发表于 2016-11-15 12:52

遇到一个情况请教一下，如何写才好

原来EXCEL中有一个表叫，“统计表”，写入VBA时代码为Sheets("统计表")

但现在有一个问题就是，每个EXCEL的“统计表”的前缀都不一样。VBA要写入每一个EXCEL之中，比如2月份的EXCEL中为“2月统计表”，3月份的EXCEL中为“3月统计表”，后面统计表这三个字则完全一样。

这个在原来Sheets("统计表")的基础上要如何修改才能自动识别得到统计表这三个字呢？

最佳答案

月排行榜 / 总排行榜

su45

2016-11-15 18:04

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
If InStr(sh.Name, "录入表") Then
With sh
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:o" & r)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
ReDim brr(1 To 2)
Else
brr = d(arr(i, 1))
End If
brr(1) = brr(1) + arr(i, 14)
brr(2) = brr(2) + arr(i, 15)
d(arr(i, 1)) = brr
Next
End With
End If
Next
With Worksheets("统计表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("H:I").ClearContents
.Range("H1") = "打包数量": .Range("I1") = "生产数量"
arr = .Range("b2:b" & r)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
If d.exists(arr(i, 1)) Then
brr = d(arr(i, 1))
crr(i, 1) = brr(1)
crr(i, 2) = brr(2)
End If
Next
.Range("H2").Resize(UBound(crr), 2) = crr
End With
End Sub

复制代码

跳转到最佳答案楼层

dsmch · 发表于 2016-11-15 13:00

Sub Macro1()
For i = 1 To 3
MsgBox Sheets(i & "月统计表").[a1]
Next
End Sub

复制代码

13724841877 · 发表于 2016-11-15 13:26

dsmch 发表于 2016-11-15 13:00

For i = 1 To 3
With Worksheets(i & "月统计表"）
Next

.......

我放这段代码放在我的VBA中，好像实现不了效果，无论如何放不是显示下超标界，就是显示没有FOR。因为我这里是用With Worksheets，下面还有很多代码。

su45 · 发表于 2016-11-15 13:42

要看你的附件或整段代码，才能准确告诉你！

13724841877 · 发表于 2016-11-15 14:17

su45 发表于 2016-11-15 13:42
要看你的附件或整段代码，才能准确告诉你！

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("2月份录入表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:o" & r)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
ReDim brr(1 To 2)
Else
brr = d(arr(i, 1))
End If
brr(1) = brr(1) + arr(i, 14)
brr(2) = brr(2) + arr(i, 15)
d(arr(i, 1)) = brr
Next
End With
With Worksheets("统计表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("b2:b" & r)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
If d.exists(arr(i, 1)) Then
brr = d(arr(i, 1))
crr(i, 1) = brr(1)
crr(i, 2) = brr(2)
End If
Next
.Range("H2").Resize(UBound(crr), 2) = crr
End With
End Sub

就在第6行中的，With Worksheets("2月份录入表")这里，这里每个EXCEL都不同。

其实这个表还有一个问题，就是“统计表”中“A列批次”空白时，右侧的数据至少缺一个或者全部都没有。其实条件值应该是“统计表”中的“B列”，是B列有数据时“H与I列”才会有数据，否则那两列均自动清空，这个问题你也能解决吗？

su45 · 发表于 2016-11-15 14:40

你试试：

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("2月份录入表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:o" & r)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
ReDim brr(1 To 2)
Else
brr = d(arr(i, 1))
End If
brr(1) = brr(1) + arr(i, 14)
brr(2) = brr(2) + arr(i, 15)
d(arr(i, 1)) = brr
Next
End With
For Each sh In Sheets
If InStr(sh.Name, "统计表") Then
With sh
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("b2:b" & r)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
If d.exists(arr(i, 1)) And arr(i, 1) <> "" Then
a = a + 1
brr = d(arr(i, 1))
crr(a, 1) = brr(1)
crr(a, 2) = brr(2)
End If
Next
.Range("H2").Resize(a, 2) = crr
End With
Exit For
End If
Next
End Sub

复制代码

13724841877 · 发表于 2016-11-15 16:55

su45 发表于 2016-11-15 14:40
你试试：

你好。谢谢，又迈向一大步了。
1.我想改的位置是
With Worksheets("2月份录入表")

因为其他EXCEL还有With Worksheets("3月份录入表")之类的。

2.B列没有数据时，H与J列的旧数据尚在，需要清空（详见附图）

su45 · 发表于 2016-11-15 18:04

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
If InStr(sh.Name, "录入表") Then
With sh
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:o" & r)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
ReDim brr(1 To 2)
Else
brr = d(arr(i, 1))
End If
brr(1) = brr(1) + arr(i, 14)
brr(2) = brr(2) + arr(i, 15)
d(arr(i, 1)) = brr
Next
End With
End If
Next
With Worksheets("统计表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("H:I").ClearContents
.Range("H1") = "打包数量": .Range("I1") = "生产数量"
arr = .Range("b2:b" & r)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
If d.exists(arr(i, 1)) Then
brr = d(arr(i, 1))
crr(i, 1) = brr(1)
crr(i, 2) = brr(2)
End If
Next
.Range("H2").Resize(UBound(crr), 2) = crr
End With
End Sub

复制代码

13724841877 · 发表于 2016-11-16 09:33

1.现在A列的批次，最后那行没有数据的情况下，相对应的H与I列就无显示了。
2.如果只有一个批次就会显示工程错误“ ReDim crr(1 To UBound(arr), 1 To 2)”

希望是否有数据以B列为准，而不是A列为准，望老师帮下手。

su45 · 发表于 2016-11-16 12:44

你要回复我的帖子，我才知道呀！

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