Zusammengelegte Zellen umhüllen, Zeilen mit Zellen löschen "" Excel VBA

Question

Ich habe zwei Blätter. Auf der ersten Seite füllen Sie die benötigten Informationen aus und eine weitere ist im Grunde eine Vorlage, in der Informationen aus dem Blatt (1) enthalten sind.

Blatt (2) ist voller Formeln wie = IF (Blatt (1)! A1 = ""; ""; Blatt (1)! A1).
Also auf dem Blatt (2) ist eine Menge von Werten mit "", die im Grunde leer sind. Ich möchte die gesamte Zeile löschen, wenn in dieser Zeile kein Text vorhanden ist.

Also, wenn die Zeile wie folgt aussieht:

A33 („“) B33 („“) C33 („“) D33 („“) E33 („“) F33 („“) G33 (etwas Text) H33 ("") I33 ("") - es sollte

bleiben A34 ("") B34 (") C34 (") D34 (") E34 (") F34 (") G34 ("") H34 ("") I34 ("") - sollte gelöscht werden

Auch auf dem Blatt (2) habe ich Zellen zusammengefügt und Text aus der entsprechenden Zelle in Blatt (1) passt nicht hinein. Ich möchte diese Zellen umhüllen, die sich in Bereich Sheet (2) befinden! B31: D68 (B31: D31 und B32: D32 und so weiter) werden zusammengeführt.

Hier ist mein Code, aber zum Beispiel Wrap für verbundene Zellen funktioniert nicht. Der Code versteckt die Zeilen, die ich löschen möchte. Code versteckt auch Zeilen mit meinem Text in Sheet (2), die als Ergebnis von Sheet (1) kommen.

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

Dies sollte richtig funktionieren, wenn Sie die Zellen in Sheet (2) unmerge, bevor es den Markt:

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