VBA Zeilen löschen, wenn Zelle im Bereich leer ist?

Question

Ich habe ein Arbeitsblatt wie so:

Column A < - - - -   
A     | 
B     - - - - Range A30:A39 
C     | 
        | 
      < - - - - 
Next Line 



Text way down here 

ich diesen Code verwenden die leeren Zellen in meinem Bereich A30 zu löschen: 39. Dieser Bereich liegt über dem Wert "Nächste Linie".

wStemplaTE.Range("A30:A39").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 

In einer idealen Welt sollte dieser Code führen dies geschehen kann:

Column A 
A 
B 
C 
Next Line 


Text way down here 

Aber stattdessen ist es verursacht das letzte Stück des Textes nach oben wie folgt zu verschieben:

Column A 
A 
B 
C 
Next Line 
Text Way down here 

Weiter Linie und Text sind hier nicht einmal in diesem Bereich.

Kann mir jemand zeigen, was ich falsch mache?

My Entire code: 

Sub Create() 
'On Error GoTo Message 
Application.DisplayAlerts = False 
Application.ScreenUpdating = False 
    Dim WbMaster As Workbook 
    Dim wbTemplate As Workbook 
    Dim wStemplaTE As Worksheet 
    Dim i As Long 
    Dim LastRow As Long 
    Dim rngToChk As Range 
    Dim rngToFill As Range 
    Dim rngToFill2 As Range 
    Dim rngToFill3 As Range 
    Dim rngToFill4 As Range 
    Dim rngToFill5 As Range 
    Dim rngToFill6 As Range 
    Dim rngToFill7 As Range 
    Dim rngToFill8 As Range 
    Dim rngToFill9 As Range 
    Dim rngToFil20 As Range 
    Dim CompName As String 
    Dim TreatedCompanies As String 
    Dim FirstAddress As String 
    '''Reference workbooks and worksheet 
    Set WbMaster = ThisWorkbook 

    '''Loop through Master Sheet to get company names 
    With WbMaster.Sheets(2) 
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     '''Run Loop on Master 
     For i = 2 To LastRow 
      '''Company name 
      Set rngToChk = .Range("B" & i) 
      CompName = rngToChk.value 

      If InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then 
       '''Company already treated, not doing it again 
      Else 
       '''Open a new template 
       Set wbTemplate = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\Templates\template.xlsx") 
       Set wStemplaTE = wbTemplate.Sheets(1) 

       '''Set Company Name to Template 
       wStemplaTE.Range("C12").value = CompName 
       wStemplaTE.Range("C13").value = rngToChk.Offset(, 1).value 
       wStemplaTE.Range("C14").value = rngToChk.Offset(, 2).value 
       wStemplaTE.Range("C15").value = rngToChk.Offset(, 3).value 
       wStemplaTE.Range("C16").value = Application.UserName 
       wStemplaTE.Range("C17").value = Now() 
       wStemplaTE.Range("A20").value = "Announcement of Spot Buy Promotion - Week " & ThisWorkbook.Worksheets(1).Range("I8").value & " " & ThisWorkbook.Worksheets(1).Range("T8").value 







       Dim strDate 
       Dim strResult 
       strDate = rngToChk.Offset(, 14).value 
       wStemplaTE.Range("C25").value = "Week " & ThisWorkbook.Worksheets(1).Range("I8").value & " " & ThisWorkbook.Worksheets(1).Range("T8").value & " " & WeekdayName(Weekday(strDate)) & " (" & strDate & ")" 

       'Set Delivery Date 
       wStemplaTE.Range("C26").value = WeekdayName(Weekday(rngToChk.Offset(, 15).value)) & " (" & rngToChk.Offset(, 15).value & ")" 






       '''Add it to to the list of treated companies 
       TreatedCompanies = TreatedCompanies & "/" & CompName 
       '''Define the 1st cell to fill on the template 
       Set rngToFill = wStemplaTE.Range("A30") 
       Set rngToFill2 = wStemplaTE.Range("B30") 
       Set rngToFill3 = wStemplaTE.Range("C30") 
       Set rngToFill4 = wStemplaTE.Range("D30") 
       Set rngToFill5 = wStemplaTE.Range("E30") 
       Set rngToFill6 = wStemplaTE.Range("F30") 
       Set rngToFill7 = wStemplaTE.Range("G30") 

       Set rngToFill8 = wStemplaTE.Range("C13") 
       Set rngToFill9 = wStemplaTE.Range("C14") 
       Set rngToFil20 = wStemplaTE.Range("C15") 




       With .Columns(2) 
        '''Define properly the Find method to find all 
        Set rngToChk = .Find(What:=CompName, _ 
           After:=rngToChk.Offset(-1, 0), _ 
           LookIn:=xlValues, _ 
           LookAt:=xlWhole, _ 
           SearchOrder:=xlByColumns, _ 
           SearchDirection:=xlNext, _ 
           MatchCase:=False, _ 
           SearchFormat:=False) 

        '''If there is a result, keep looking with FindNext method 
        If Not rngToChk Is Nothing Then 
         FirstAddress = rngToChk.Address 
         Do 
          '''Transfer the cell value to the template 
          rngToFill.value = rngToChk.Offset(, 7).value 
          rngToFill2.value = rngToChk.Offset(, 8).value 
          rngToFill3.value = rngToChk.Offset(, 9).value 
          rngToFill4.value = rngToChk.Offset(, 10).value 
          rngToFill5.value = rngToChk.Offset(, 11).value 
          rngToFill6.value = rngToChk.Offset(, 12).value 
          rngToFill7.value = rngToChk.Offset(, 13).value 



          '''Go to next row on the template for next Transfer 
          Set rngToFill = rngToFill.Offset(1, 0) 
          Set rngToFill2 = rngToFill.Offset(0, 1) 
          Set rngToFill3 = rngToFill.Offset(0, 2) 
          Set rngToFill4 = rngToFill.Offset(0, 3) 
          Set rngToFill5 = rngToFill.Offset(0, 4) 
          Set rngToFill6 = rngToFill.Offset(0, 5) 
          Set rngToFill7 = rngToFill.Offset(0, 6) 



          '''Look until you find again the first result 
          Set rngToChk = .FindNext(rngToChk) 
         Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress 
        Else 
        End If 
       End With '.Columns(2) 






       Set Rng = Range("D30:G39") 
       Rng.Select 
       Set cell = Selection.Find(What:="#VALUE!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 

       If cell Is Nothing Then 
       'do it something 
       Else 
       For Each cell In Rng 
       cell.value = "TBC" 
       Next 
'End For 
wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." 
End If 


       Rng.Select 
       Set cell = Selection.Find(What:="TBC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 

       If cell Is Nothing Then 
       'do it something 
       Else 

wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." 
End If 

'Remove uneeded announcement rows 
wStemplaTE.Range("A30:A39").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 









       file = AlphaNumericOnly(CompName) 
       wbTemplate.SaveCopyAs filename:="G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\" & file & ".xlsx" 
       wbTemplate.Close False 
      End If 
     Next i 
    End With 'wbMaster.Sheets(2) 
    Application.DisplayAlerts = True 
Application.ScreenUpdating = True 


Dim answer As Integer 
answer = MsgBox("Announcements Successfully Created." & vbNewLine & vbNewLine & "Would you like to view these now?", vbYesNo + vbQuestion, "Notice") 
If answer = vbYes Then 
Call List 
Else 
    'do nothing 
End If 

Exit Sub 

Message: 
wbTemplate.Close savechanges:=False 
MsgBox "One or more files are in use. Please make sure all Announcement files are closed and try again." 
Exit Sub 

End Sub 



Function AlphaNumericOnly(strSource As String) As String 
    Dim i As Integer 
    Dim strResult As String 

    For i = 1 To Len(strSource) 
     Select Case Asc(Mid(strSource, i, 1)) 
      Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space 
       strResult = strResult & Mid(strSource, i, 1) 
     End Select 
    Next 
    AlphaNumericOnly = strResult 
End Function 




Function FindAll(SearchRange As Range, _ 
       FindWhat As Variant, _ 
       Optional LookIn As XlFindLookIn = xlValues, _ 
       Optional LookAt As XlLookAt = xlWhole, _ 
       Optional SearchOrder As XlSearchOrder = xlByRows, _ 
       Optional MatchCase As Boolean = False, _ 
       Optional BeginsWith As String = vbNullString, _ 
       Optional EndsWith As String = vbNullString, _ 
       Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range 

       End Function 

Answer 1

Ändern Sie die Spalte nach Bedarf. Gerade jetzt ist es funktioniert auf Spalte A. Sie können es ein Argument, um den Benutzer zu fragen, wie der zweite Code

Public Sub DeleteRowOnCell() 
'==================================================================================== 
'This macro will delete the entire row if a cell in the specified column is blank. 
'Only one specified column is checked. Other columns are ignored. 
'==================================================================================== 
    On Error Resume Next 
    Range("A3:A" & Rows.count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
    On Error GoTo 0 
End Sub 

Public Sub DeleteRowOnCellAsk() 
'==================================================================================== 
'This macro will delete the entire row if a cell in the specified column is blank. 
'Only one specified column is checked. Other columns are ignored. 
'==================================================================================== 
    Dim inp As String 
    inp = InputBox("Please enter a column name based on which blank rows will be deleted", "Which Column?") 
    Debug.Print inp & ":" & inp & Rows.count 
    On Error Resume Next 
     Range(inp & "1" & ":" & inp & Rows.count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
End Sub