Question

这是我的第一篇帖子，请原谅任何天真。

我正在使用Excel中的电子表格，但我对VBA很新，需要很多帮助。

有4个选项卡可以输入数据，质量通常很差，需要整理才能在别处用于邮件合并等。

标签名为“Goodwill”，“Refund”，“Furniture Goodwill”和“Furniture Refund”

工作区域从A1到V500。第1行包含标题，需要保持不变。

原始数据输入到每个标签后，我需要有一个宏，它将依次为每个标签执行以下操作： -

A列中的数据将是输入人员的姓名。我需要删除包含A列数据的所有行，但在列V之前的所有其他列中都是空白。
然后我需要删除任何空的行，然后将所有数据向上移动，以便我有一个信息块。

3.然后需要修剪剩余数据以删除任何前面和后面的空格以及中间的任何随机空格。

然后需要将数据格式化为正确的文本，以便为邮件合并做好准备。
然后需要将现在完成的数据拆分为25行的部分并导出到新选项卡以满足邮件合并的要求。

是否有可以执行所有这些操作的代码？如果有，可以包含在1个宏中，还是每个函数需要1个？

提前谢谢大家。

Answer 1

我会将每个“函数”保持在一个单独的Sub中，并让它们从“主”子一个接一个地调用，如下所示：

Option Explicit

Sub Main()
    Dim shtNames As Variant, shtName As Variant

    shtNames = Array("Goodwill", "Refund", "Furniture Goodwill", "Furniture Refund")
    For Each shtName In shtNames
        With Worksheets(shtName)
            DeleteRowsWithNoData .Name
            DeleteEmptyRows .Name
            RemoveLeadingAndTrailingSpaces .Name
            SplitToTabs .Name, 25
        End With
    Next
End Sub

Sub DeleteRowsWithNoData(shtName As String)
    Dim iRow As Long
    With Worksheets(shtName) '<--| reference passed worksheet
        With .Range("V2", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its columns A:V range from row 2 down to last column A not empty row
            For iRow = .Rows.count To 1 Step -1 '<--| iterate rows backwards up to row 2 to prevent skipping rows
                If WorksheetFunction.CountA(.Rows(iRow)) <= 1 Then .Rows(iRow).EntireRow.Delete
            Next
         End With
    End With
End Sub

Sub DeleteEmptyRows(shtName As String)
    With Worksheets(shtName) '<--| reference passed worksheet
        With .Range("A1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its column A from row 1 down to last not empty row
            If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete '<--| if any blank cells then delete corresponding entire row
        End With
    End With
End Sub


Sub RemoveLeadingAndTrailingSpaces(shtName As String)
    With Worksheets(shtName) '<--| reference passed worksheet
        With .Range("V2", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its column A from row 1 down to last not empty row
            .Value = Evaluate("if(" & .Address & "<>"""",trim(" & .Address & "),"""")")
        End With
    End With
End Sub

Sub SplitToTabs(shtName As String, nRows As Long)
    Dim iRow As Long

    iRow = 1
    With Worksheets(shtName) '<--| reference passed worksheet
        With .Range("V2", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its columns A:V range from row 2 down to last column A not empty row
            Do
                .Rows(iRow).Resize(nRows).Copy Destination:=GetNewSheet(shtName & "-" & CStr(iRow \ nRows + 1)).Range("A1")
                iRow = iRow + nRows
            Loop While iRow < .Rows.count
         End With
    End With
End Sub

Function GetNewSheet(shtName As String) As Worksheet
    With Worksheets
        On Error Resume Next
        Set GetNewSheet = .item(shtName)
        On Error GoTo 0
        If GetNewSheet Is Nothing Then
            Set GetNewSheet = .Add(after:=.item(.count))
            GetNewSheet.Name = shtName
        Else
            GetNewSheet.UsedRange.ClearContents
        End If
    End With
End Function

并且你可以为正确问题插入一个类似的“功能”，你写的那个已经自己解决了

1个工作簿中的多个VBA宏

1 个答案: