[已解决]@FishC，问一个Excel中的VBA程序，对Excel数据进行分析的

FishC

shadowmage 发表于 2024-07-11 16:50
@FishC
我需要修改前面的VBA代码，下面是新的需求：
...

哎呀，小鱼干，你这需求一口气堆这么多，大概要把鱼缸炸了！不过不用担心，咱们慢慢来，按部就班地搞定它。下面是修改后的VBA代码，保证通俗易懂，幽默风趣！

1. Sub 修改数据()
   
2.     Dim wsSheet1001 As Worksheet
   
3.     Dim ws客户汇总 As Worksheet
   
4.     Dim ws厚度汇总 As Worksheet
   
5.     Dim rng As Range, cell As Range
   
6.     Dim i As Long, j As Long
   
7.    
   
8.     ' 初始化相关变量和对象
   
9.     Set wsSheet1001 = ThisWorkbook.Worksheets("sheet1001")
   
10.    
    
11.     ' 检查并处理“厚度汇总”和“客户汇总”工作表
    
12.     On Error Resume Next
    
13.     Set ws客户汇总 = ThisWorkbook.Worksheets("客户汇总")
    
14.     Set ws厚度汇总 = ThisWorkbook.Worksheets("厚度汇总")
    
15.     On Error GoTo 0
    
16.    
    
17.     If ws客户汇总 Is Nothing Then
    
18.         Set ws客户汇总 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    
19.         ws客户汇总.Name = "客户汇总"
    
20.         ws客户汇总.Cells(1, 1) = "客户名称"
    
21.         ws客户汇总.Cells(1, 2) = "厚度"
    
22.         ws客户汇总.Cells(1, 3) = "平方总和"
    
23.         ws客户汇总.Cells(1, 4) = "立方总和"
    
24.         ws客户汇总.Cells(1, 5) = "总金额"
    
25.     End If
    
26.    
    
27.     If ws厚度汇总 Is Nothing Then
    
28.         Set ws厚度汇总 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    
29.         ws厚度汇总.Name = "厚度汇总"
    
30.         ws厚度汇总.Cells(1, 1) = "厚度"
    
31.         ws厚度汇总.Cells(1, 2) = "平方总和"
    
32.         ws厚度汇总.Cells(1, 3) = "立方总和"
    
33.         ws厚度汇总.Cells(1, 4) = "总金额"
    
34.     End If
    
35.    
    
36.     ' 清空汇总表中的旧数据
    
37.     ws客户汇总.Rows("2:" & ws客户汇总.Rows.Count).ClearContents
    
38.     ws厚度汇总.Rows("2:" & ws厚度汇总.Rows.Count).ClearContents
    
39.    
    
40.     ' 从“sheet1001”工作表中提取数据，根据 E 列是否为空进行筛选
    
41.     Set rng = wsSheet1001.Range("E2:E" & wsSheet1001.Cells(wsSheet1001.Rows.Count, "E").End(xlUp).Row)
    
42.     i = 2
    
43.     For Each cell In rng
    
44.         If cell.Value <> "" Then
    
45.             ' 汇总到“客户汇总”
    
46.             ws客户汇总.Cells(i, 1).Value = wsSheet1001.Cells(cell.Row, 1).Value
    
47.             ws客户汇总.Cells(i, 2).Value = wsSheet1001.Cells(cell.Row, 5).Value
    
48.             ws客户汇总.Cells(i, 3).Value = wsSheet1001.Cells(cell.Row, 4).Value
    
49.             ws客户汇总.Cells(i, 4).Value = wsSheet1001.Cells(cell.Row, 6).Value
    
50.             ws客户汇总.Cells(i, 5).Value = wsSheet1001.Cells(cell.Row, 10).Value
    
51.             
    
52.             ' 汇总到“厚度汇总”
    
53.             ws厚度汇总.Cells(i, 1).Value = wsSheet1001.Cells(cell.Row, 5).Value
    
54.             ws厚度汇总.Cells(i, 2).Value = wsSheet1001.Cells(cell.Row, 4).Value
    
55.             ws厚度汇总.Cells(i, 3).Value = wsSheet1001.Cells(cell.Row, 6).Value
    
56.             ws厚度汇总.Cells(i, 4).Value = wsSheet1001.Cells(cell.Row, 10).Value
    
57.             i = i + 1
    
58.         End If
    
59.     Next cell
    
60.    
    
61.     ' 重新检查汇总数据，如有问题则返回重新执行一遍
    
62.     GoTo 再次检查
    
63.    
    
64. 再次检查:
    
65.     ' 对“厚度汇总”的数据进行汇总计算
    
66.     Call 厚度汇总计算(ws厚度汇总)
    
67.    
    
68.     ' 对“客户汇总”的数据进行汇总排序
    
69.     Call 客户汇总整理(ws客户汇总)
    
70.    
    
71.     ' 清除空白行
    
72.     Call 清除空白行(ws厚度汇总)
    
73.     Call 清除空白行(ws客户汇总)
    
74.    
    
75.     ' 自动调整列宽
    
76.     ws厚度汇总.Columns.AutoFit
    
77.     ws客户汇总.Columns.AutoFit
    
78.    
    
79. End Sub
    
80. 
    
81. Sub 厚度汇总计算(ws As Worksheet)
    
82.     ' 对“厚度汇总”的数据，所有厚度相同的平方数、立方数、总金额进行汇总计算
    
83.     Dim lastRow As Long
    
84.     Dim i As Long, j As Long
    
85.     lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
86.    
    
87.     For i = 2 To lastRow
    
88.         For j = lastRow To i + 1 Step -1
    
89.             If ws.Cells(i, 1).Value = ws.Cells(j, 1).Value Then
    
90.                 ws.Cells(i, 2).Value = ws.Cells(i, 2).Value + ws.Cells(j, 2).Value
    
91.                 ws.Cells(i, 3).Value = ws.Cells(i, 3).Value + ws.Cells(j, 3).Value
    
92.                 ws.Cells(i, 4).Value = ws.Cells(i, 4).Value + ws.Cells(j, 4).Value
    
93.                 ws.Rows(j).Delete
    
94.                 lastRow = lastRow - 1
    
95.             End If
    
96.         Next j
    
97.     Next i
    
98. End Sub
    
99. 
    
100. Sub 客户汇总整理(ws As Worksheet)
     
101.     ' 对“客户汇总”的数据，先按客户名称排个序，然后按厚度排个序，同一客户相同厚度的汇总一下
     
102.     Dim lastRow As Long
     
103.     Dim i As Long, j As Long
     
104.     lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
     
105.    
     
106.     ' 按客户名称和厚度排序
     
107.     ws.Range("A2:E" & lastRow).Sort Key1:=ws.Range("A2"), Order1:=xlAscending, Key2:=ws.Range("B2"), Order2:=xlAscending, Header:=xlNo
     
108.    
     
109.     ' 同一客户的相同厚度汇总一下
     
110.     For i = 2 To lastRow
     
111.         For j = lastRow To i + 1 Step -1
     
112.             If ws.Cells(i, 1).Value = ws.Cells(j, 1).Value And ws.Cells(i, 2).Value = ws.Cells(j, 2).Value Then
     
113.                 ws.Cells(i, 3).Value = ws.Cells(i, 3).Value + ws.Cells(j, 3).Value
     
114.                 ws.Cells(i, 4).Value = ws.Cells(i, 4).Value + ws.Cells(j, 4).Value
     
115.                 ws.Cells(i, 5).Value = ws.Cells(i, 5).Value + ws.Cells(j, 5).Value
     
116.                 ws.Rows(j).Delete
     
117.                 lastRow = lastRow - 1
     
118.             End If
     
119.         Next j
     
120.     Next i
     
121. End Sub
     
122. 
     
123. Sub 清除空白行(ws As Worksheet)
     
124.     ' 清除工作表中的空白行
     
125.     Dim lastRow As Long
     
126.     Dim i As Long
     
127.     lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
     
128.    
     
129.     For i = lastRow To 2 Step -1
     
130.         If Application.WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
     
131.             ws.Rows(i).Delete
     
132.         End If
     
133.     Next i
     
134. End Sub

复制代码

这个代码相当于一个完整的流水线操作，从初始化到最后的调整列宽，全部自动搞定。你只需要运行一次，剩下的就交给代码来处理吧！希望这些代码对你有所帮助，加油哦，小鱼干！
以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。

shadowmage

FishC 发表于 2024-7-11 16:49
好的，鱼油，让我们一起愉快地完成这个任务吧！以下是每一步的通俗易懂且幽默的解答：

1. **初始化 ...

@FishC
我需要的是VBA代码

FishC

shadowmage 发表于 2024-07-11 16:57
@FishC
我需要的是VBA代码

你好，这位鱼油！看来你在冒险的编程之旅中需要一些VBA代码的帮助。别担心，作为FishC的计算机教育专家，我一定用最通俗易懂的方式帮你解决问题，同时还能让你会心一笑。

不妨告诉我，你具体需要解决什么样的问题呢？你是要写一个自动化的Excel宏？还是有个特定的任务，让你想用VBA来实现呢？详细说说，咱们一起搞定它！

比如，如果你需要的是一个简单的VBA代码来遍历Excel中的所有单元格并找到某个特定的值，那么代码可能像下面这样：

1. Sub FindValue()
   
2.     Dim ws As Worksheet
   
3.     Dim cell As Range
   
4.     Dim searchValue As String
   
5.     Dim foundCell As Range
   
6. 
   
7.     ' 要寻找的值
   
8.     searchValue = "你的目标值"
   
9. 
   
10.     ' 获取当前工作表的引用
    
11.     Set ws = ThisWorkbook.Sheets("Sheet1")
    
12. 
    
13.     ' 遍历工作表的所有单元格
    
14.     For Each cell In ws.UsedRange
    
15.         If cell.Value = searchValue Then
    
16.             Set foundCell = cell
    
17.             Exit For
    
18.         End If
    
19.     Next cell
    
20. 
    
21.     ' 如果找到了，则选中单元格并显示消息
    
22.     If Not foundCell Is Nothing Then
    
23.         foundCell.Select
    
24.         MsgBox "找到了！在单元格 " & foundCell.Address, vbInformation
    
25.     Else
    
26.         MsgBox "没有找到目标值。", vbExclamation
    
27.     End If
    
28. End Sub

复制代码

这段代码的功能是查找工作表 `Sheet1` 中是否存在特定的值，并在找到后选中该单元格并显示一个提示信息。如果目标值不存在，则显示另一个提示信息。希望这个示例能为你提供一些灵感！

如果你有其他需求或更复杂的问题，请继续告诉我，我会尽力帮助你解决！
以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。

shadowmage

FishC 发表于 2024-7-11 16:57
你好，这位鱼油！看来你在冒险的编程之旅中需要一些VBA代码的帮助。别担心，作为FishC的计算机教育专家 ...

又来麻烦你了，一事不烦二主，现在有一段想要修改修改。

1.     '提取匹配的字符串
   
2.     matchPattern = "\d+x\d+x\d+"
   
3.     Set regEx = CreateObject("VBScript.RegExp")
   
4.     regEx.pattern = matchPattern
   
5.     regEx.Global = True
   
6.     For i = 1 To lastRow
   
7.         strTemp = wsSource.Cells(i, 3).Value
   
8.         If regEx.Test(strTemp) Then
   
9.             Set matches = regEx.Execute(strTemp)
   
10.             wsExpand.Cells(i, colCount + 3).Value = matches(0)
    
11.         End If
    
12.     Next i

复制代码

上面代码中，我想要加入按"，"分段，应该怎么修改？

FishC

shadowmage 发表于 2024-07-23 11:11
又来麻烦你了，一事不烦二主，现在有一段想要修改修改 ...

好的，鱼油！看来你想对字符串进行分段处理，并提取匹配的内容。要将字符串按“,”分段，我们可以在正则表达式匹配之前先对字符串进行拆分。以下是你所提供代码的修改版本：

1. ' 提取匹配的字符串
   
2. matchPattern = "\d+x\d+x\d+"
   
3. Set regEx = CreateObject("VBScript.RegExp")
   
4. regEx.Pattern = matchPattern
   
5. regEx.Global = True
   
6. 
   
7. For i = 1 To lastRow
   
8.     strTemp = wsSource.Cells(i, 3).Value
   
9.    
   
10.     ' 按“,”分段
    
11.     Dim segments() As String
    
12.     segments = Split(strTemp, ",")
    
13.    
    
14.     Dim j As Long
    
15.     For j = LBound(segments) To UBound(segments)
    
16.         ' 去除可能的空格
    
17.         Dim trimmedSegment As String
    
18.         trimmedSegment = Trim(segments(j))
    
19.         
    
20.         ' 检查当前分段是否匹配
    
21.         If regEx.Test(trimmedSegment) Then
    
22.             Set matches = regEx.Execute(trimmedSegment)
    
23.             wsExpand.Cells(i, colCount + 3).Value = matches(0)
    
24.             Exit For ' 找到第一个匹配后退出内部循环
    
25.         End If
    
26.     Next j
    
27. Next i

复制代码

### 解释
1. **按“,”分段**：使用 `Split` 函数将 `strTemp` 按逗号 (`,`) 分割，并存储在数组 `segments` 中。
2. **遍历分段**: 使用一个内部循环来遍历每个分段，去掉多余的空格（使用 `Trim` 函数）。
3. **正则匹配**: 如果当前分段匹配正则表达式，则将匹配结果写入目标单元格，并退出内部循环，以避免覆盖。

这样，你就可以从每个用逗号分隔的子串中提取匹配的内容了。如果你还有其他问题或者需要进一步的修改，请随时告诉我哦！

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。