多個VBA宏在1工作簿

Question

這是我的第一篇文章，所以請原諒任何天真。

我正在Excel的電子表格中工作，但我對VBA很陌生，需要大量的幫助。

有4個選項卡，其中數據將被輸入，並且通常質量較差，需要整理才能在其他地方用於郵件合併和類似處理。

的選項卡被命名爲「善意」，「退款」，「傢俱善意」和「傢俱退款」

工作區從單元A1至V500運行。第1行包含標題，需要保持不變。

一旦原始數據已經輸入到每一個我需要有一個宏，會爲每個標籤下面依次標籤： -

1. 在A列中的數據將是輸入人的名。我需要刪除列A中包含數據的所有行，但在列V以前的所有其他列中都爲空白。

2. 然後，我需要刪除任何空的行，然後將所有數據移動到所以我有一塊信息。

3.然後需要修剪剩餘的數據以刪除任何前後空格以及中間的任意隨機數。

1. 然後需要將數據格式化爲正確的文本，以便它可以進行郵件合併。

2. 現在完成的數據需要拆分成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 

，並在那裏你可以插入一個類似的「功能」對於正確的問題，你寫的你已經解決了你自己