包裝合併的單元格，刪除單元格的行Excel Excel VBA

Question

我有兩個表格。第一個填寫需要的信息，另一個基本上是Sheet（1）中信息的模板。 （2）充滿了類似= IF（Sheet（1）！A1 =「」;「」; Sheet（1）！A1）的公式。
所以在表（2）上有很多值「」，基本上都是空白的。如果在這一行中沒有文本，我想刪除整行。

因此，如果該行的樣子：

A33（「」），B33（「」），C33（「」）D33（「」）E33（「」），F33（「」），G33（一些文本） H33（「」）I33（「」） - 它應該停留

A34（「」）B34（「」）C34（「」）D34（「」）E34 「」）H34（「」）I34（「」） - 應該被刪除

同樣在表（2）上，我已經合併單元格和來自Sheet（1）中相應單元格的文本不適合那裏。我想將這些單元格放在範圍表（2）！B31：D68（B31：D31和B32：D32等）中進行合併。

這是我的代碼，但例如Wrap for merged cells does not work。代碼隱藏了我需要刪除的行。代碼也是將Sheet（2）中的文本隱藏在來自Sheet（1）的結果中。

Sub AutofitRows() 
    Dim CL As Range 

    For Each CL In ActiveWorkbook.Sheets(2).Range("A30:I68") 
     If CL.WrapText Then CL.rows.AutoFit 
    Next 
End Sub 
Sub removecellswithemptycells() 
    ActiveWorkbook.Sheets(2).Select 
    Set rr = Range("A30:J66") 
    For Each cell In rr 
    cell.Select 
     If cell.HasFormula = True And cell.Value = "" And cell.EntireRow.Hidden = False Then rows(cell.Row).EntireRow.Hidden = True 
    Next cell 
End Sub 
Sub removecellswithemptycells_pos2() 
    ActiveWorkbook.Sheets(2).Select 
    Set rr = Range("A21:J22") 
    For Each cell In rr 
    cell.Select 
     If cell.HasFormula = True And cell.Value = "" And cell.EntireRow.Hidden = False Then rows(cell.Row).EntireRow.Hidden = True 
    Next cell 
End Sub 
Sub dothefiles() 
    Dim NewPath As String 
    Dim iFileName$, iRow& 
    NewPath = Application.ThisWorkbook.Path & "\" & "Order" 
    If Dir(NewPath, 63) = "" Then MkDir NewPath 

     ActiveWorkbook.Sheets(2).Select 
     ActiveSheet.ExportAsFixedFormat _ 
     Type:=xlTypePDF, _ 
     Filename:=NewPath & "\" & [Sheet(1)!C17] & "-" & [Sheet(1)!C6] & " " & "Order" & " " & [Sheet(1)!C10] & " " & Date & ".pdf", _ 
     Quality:=xlQualityStandard, _ 
     IncludeDocProperties:=True, _ 
     IgnorePrintAreas:=No, _ 
     OpenAfterPublish:=False 

    iFileName = NewPath & "\" & [Sheet(1)!C17] & "-" & [Sheet(1)!C6] & " " & "Order" & " " & [Sheet(1)!C10] & " " & Date & ".xls" 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.Calculation = xlManual 

    ThisWorkbook.Sheets(2).Copy 
    With ActiveWorkbook.ActiveSheet 
     .Buttons.Delete '.Shapes("Button 1").Delete 
     .UsedRange.Value = .UsedRange.Value 
     For iRow = .Cells(.rows.Count, 2).End(xlUp).Row To 5 Step -1 
      If Application.CountA(.rows(iRow)) = 1 Then .rows(iRow).Delete 
     Next 
     .SaveAs iFileName, xlExcel8: .Parent.Close 
    End With 

    Application.Calculation = xlAutomatic 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 

End Sub 
Sub doitallplease() 
    Call AutofitRows 
    Call removecellswithemptycells 
    Call removecellswithemptycells_pos2 
    Call dothefiles 
End Sub 

Answer 1

，如果你取消合併單元格中的表（2）本應正常工作啓動前：

Option Explicit 

Public tB As Workbook 
Public wS1 As Worksheet 
Public wS2 As Worksheet 
Public wSCopy As Worksheet 

Sub CreateCleanCopies() 
    Dim NewPath As String 
    Dim iFileName$, iRow& 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
     .DisplayAlerts = False 
     .Calculation = xlManual 
    End With 'Application 

    Set tB = ThisWorkbook 
    Set wS1 = tB.Sheets(1) 
    Set wS2 = tB.Sheets(2) 

    NewPath = tB.Path & "\" & "Order" 
    iFileName = NewPath & "\" & wS1.Range("C17") & "-" & wS1.Range("C6") & " " & "Order" & " " & wS1.Range("C10") & " " & Date & ".pdf" 
    If Dir(NewPath, 63) = vbNullString Then MkDir NewPath 

    wS2.Copy 
    Set wSCopy = ActiveWorkbook.ActiveSheet 

    AutofitRowsAndMerge wSCopy, "A30:I68" 

    RemoveEmptyRows wSCopy, "A30:J66" 
    RemoveEmptyRows wSCopy, "A21:J22" 

    With wSCopy 
     .ExportAsFixedFormat _ 
      Type:=xlTypePDF, _ 
      FileName:=iFileName, _ 
      Quality:=xlQualityStandard, _ 
      IncludeDocProperties:=True, _ 
      IgnorePrintAreas:=False, _ 
      OpenAfterPublish:=False 

     iFileName = Replace(iFileName, ".pdf", ".xls") 

     .Buttons.Delete 
     .UsedRange.Value = .UsedRange.Value 


     .Parent.SaveAs iFileName, xlExcel8 
     .Parent.Close 
    End With 

    With Application 
     .DisplayAlerts = True 
     .Calculation = xlAutomatic 
     .EnableEvents = True 
     .ScreenUpdating = True 
    End With 'Application 
End Sub 

Sub AutofitRowsAndMerge(wS As Worksheet, RangeAddress As String) 
    Dim RgCL As Range 
    For Each RgCL In wS.Range(RangeAddress).Columns(1).Cells 
     With RgCL 
      If Not .WrapText Then .WrapText = True 
      .EntireRow.AutoFit 
      .Parent.Range(RgCL, .Offset(0, 2)).Merge 
     End With 'RgCL 
    Next RgCL 
End Sub 

Sub RemoveEmptyRows(wS As Worksheet, RangeAddress As String) 
    Dim RemoveRow As Boolean 
    Dim i As Double 
    Dim LastRgRow As Double 
    Dim FirstRgRow As Double 
    Dim RgCL As Range 

    With wS.Range(RangeAddress) 
     FirstRgRow = .Cells(1, 1).Row 
     LastRgRow = .Cells(.Rows.Count, 1).Row 
    End With 'wS.Range(RangeAddress) 

    For i = LastRgRow To FirstRgRow Step -1 
     RemoveRow = True 
     For Each RgCL In Application.Intersect(wS.Range(RangeAddress), wS.Rows(i)).Cells 
      If RgCL.Value <> vbNullString Then 
       RemoveRow = False 
       Exit For 
      Else 
      End If 
     Next RgCL 
     If RemoveRow Then wS.Rows(i).EntireRow.Delete 
    Next i 
End Sub