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

FishC

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

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

Sub 修改数据()
    Dim wsSheet1001 As Worksheet
    Dim ws客户汇总 As Worksheet
    Dim ws厚度汇总 As Worksheet
    Dim rng As Range, cell As Range
    Dim i As Long, j As Long
    
    ' 初始化相关变量和对象
    Set wsSheet1001 = ThisWorkbook.Worksheets("sheet1001")
    
    ' 检查并处理“厚度汇总”和“客户汇总”工作表
    On Error Resume Next
    Set ws客户汇总 = ThisWorkbook.Worksheets("客户汇总")
    Set ws厚度汇总 = ThisWorkbook.Worksheets("厚度汇总")
    On Error GoTo 0
    
    If ws客户汇总 Is Nothing Then
        Set ws客户汇总 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws客户汇总.Name = "客户汇总"
        ws客户汇总.Cells(1, 1) = "客户名称"
        ws客户汇总.Cells(1, 2) = "厚度"
        ws客户汇总.Cells(1, 3) = "平方总和"
        ws客户汇总.Cells(1, 4) = "立方总和"
        ws客户汇总.Cells(1, 5) = "总金额"
    End If
    
    If ws厚度汇总 Is Nothing Then
        Set ws厚度汇总 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws厚度汇总.Name = "厚度汇总"
        ws厚度汇总.Cells(1, 1) = "厚度"
        ws厚度汇总.Cells(1, 2) = "平方总和"
        ws厚度汇总.Cells(1, 3) = "立方总和"
        ws厚度汇总.Cells(1, 4) = "总金额"
    End If
    
    ' 清空汇总表中的旧数据
    ws客户汇总.Rows("2:" & ws客户汇总.Rows.Count).ClearContents
    ws厚度汇总.Rows("2:" & ws厚度汇总.Rows.Count).ClearContents
    
    ' 从“sheet1001”工作表中提取数据，根据 E 列是否为空进行筛选
    Set rng = wsSheet1001.Range("E2:E" & wsSheet1001.Cells(wsSheet1001.Rows.Count, "E").End(xlUp).Row)
    i = 2
    For Each cell In rng
        If cell.Value <> "" Then
            ' 汇总到“客户汇总”
            ws客户汇总.Cells(i, 1).Value = wsSheet1001.Cells(cell.Row, 1).Value
            ws客户汇总.Cells(i, 2).Value = wsSheet1001.Cells(cell.Row, 5).Value
            ws客户汇总.Cells(i, 3).Value = wsSheet1001.Cells(cell.Row, 4).Value
            ws客户汇总.Cells(i, 4).Value = wsSheet1001.Cells(cell.Row, 6).Value
            ws客户汇总.Cells(i, 5).Value = wsSheet1001.Cells(cell.Row, 10).Value
            
            ' 汇总到“厚度汇总”
            ws厚度汇总.Cells(i, 1).Value = wsSheet1001.Cells(cell.Row, 5).Value
            ws厚度汇总.Cells(i, 2).Value = wsSheet1001.Cells(cell.Row, 4).Value
            ws厚度汇总.Cells(i, 3).Value = wsSheet1001.Cells(cell.Row, 6).Value
            ws厚度汇总.Cells(i, 4).Value = wsSheet1001.Cells(cell.Row, 10).Value
            i = i + 1
        End If
    Next cell
    
    ' 重新检查汇总数据，如有问题则返回重新执行一遍
    GoTo 再次检查
    
再次检查:
    ' 对“厚度汇总”的数据进行汇总计算
    Call 厚度汇总计算(ws厚度汇总)
    
    ' 对“客户汇总”的数据进行汇总排序
    Call 客户汇总整理(ws客户汇总)
    
    ' 清除空白行
    Call 清除空白行(ws厚度汇总)
    Call 清除空白行(ws客户汇总)
    
    ' 自动调整列宽
    ws厚度汇总.Columns.AutoFit
    ws客户汇总.Columns.AutoFit
    
End Sub

Sub 厚度汇总计算(ws As Worksheet)
    ' 对“厚度汇总”的数据，所有厚度相同的平方数、立方数、总金额进行汇总计算
    Dim lastRow As Long
    Dim i As Long, j As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lastRow
        For j = lastRow To i + 1 Step -1
            If ws.Cells(i, 1).Value = ws.Cells(j, 1).Value Then
                ws.Cells(i, 2).Value = ws.Cells(i, 2).Value + ws.Cells(j, 2).Value
                ws.Cells(i, 3).Value = ws.Cells(i, 3).Value + ws.Cells(j, 3).Value
                ws.Cells(i, 4).Value = ws.Cells(i, 4).Value + ws.Cells(j, 4).Value
                ws.Rows(j).Delete
                lastRow = lastRow - 1
            End If
        Next j
    Next i
End Sub

Sub 客户汇总整理(ws As Worksheet)
    ' 对“客户汇总”的数据，先按客户名称排个序，然后按厚度排个序，同一客户相同厚度的汇总一下
    Dim lastRow As Long
    Dim i As Long, j As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 按客户名称和厚度排序
    ws.Range("A2:E" & lastRow).Sort Key1:=ws.Range("A2"), Order1:=xlAscending, Key2:=ws.Range("B2"), Order2:=xlAscending, Header:=xlNo
    
    ' 同一客户的相同厚度汇总一下
    For i = 2 To lastRow
        For j = lastRow To i + 1 Step -1
            If ws.Cells(i, 1).Value = ws.Cells(j, 1).Value And ws.Cells(i, 2).Value = ws.Cells(j, 2).Value Then
                ws.Cells(i, 3).Value = ws.Cells(i, 3).Value + ws.Cells(j, 3).Value
                ws.Cells(i, 4).Value = ws.Cells(i, 4).Value + ws.Cells(j, 4).Value
                ws.Cells(i, 5).Value = ws.Cells(i, 5).Value + ws.Cells(j, 5).Value
                ws.Rows(j).Delete
                lastRow = lastRow - 1
            End If
        Next j
    Next i
End Sub

Sub 清除空白行(ws As Worksheet)
    ' 清除工作表中的空白行
    Dim lastRow As Long
    Dim i As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For i = lastRow To 2 Step -1
        If Application.WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
            ws.Rows(i).Delete
        End If
    Next i
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中的所有单元格并找到某个特定的值，那么代码可能像下面这样：

Sub FindValue()
    Dim ws As Worksheet
    Dim cell As Range
    Dim searchValue As String
    Dim foundCell As Range

    ' 要寻找的值
    searchValue = "你的目标值"

    ' 获取当前工作表的引用
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' 遍历工作表的所有单元格
    For Each cell In ws.UsedRange
        If cell.Value = searchValue Then
            Set foundCell = cell
            Exit For
        End If
    Next cell

    ' 如果找到了，则选中单元格并显示消息
    If Not foundCell Is Nothing Then
        foundCell.Select
        MsgBox "找到了！在单元格 " & foundCell.Address, vbInformation
    Else
        MsgBox "没有找到目标值。", vbExclamation
    End If
End Sub

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

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

shadowmage

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

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

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

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

FishC

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

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

' 提取匹配的字符串
matchPattern = "\d+x\d+x\d+"
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = matchPattern
regEx.Global = True

For i = 1 To lastRow
    strTemp = wsSource.Cells(i, 3).Value
    
    ' 按“,”分段
    Dim segments() As String
    segments = Split(strTemp, ",")
    
    Dim j As Long
    For j = LBound(segments) To UBound(segments)
        ' 去除可能的空格
        Dim trimmedSegment As String
        trimmedSegment = Trim(segments(j))
        
        ' 检查当前分段是否匹配
        If regEx.Test(trimmedSegment) Then
            Set matches = regEx.Execute(trimmedSegment)
            wsExpand.Cells(i, colCount + 3).Value = matches(0)
            Exit For ' 找到第一个匹配后退出内部循环
        End If
    Next j
Next i

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

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

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