如果范围内的单元格为空，Vba删除行？

Question

我有一个工作表，如下所示：

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



Text way down here 

我使用此代码删除空单元格在我的范围A30：39。此范围位于“下一行”值的上方。

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

在一个理想的世界中，此代码应导致这种情况发生：

Column A 
A 
B 
C 
Next Line 


Text way down here 

但相反，它是造成文本的最后一位上移，这样的：

Column A 
A 
B 
C 
Next Line 
Text Way down here 

下一页行和文本的方式在这里甚至不在这个范围内。

有人可以告诉我我做错了什么吗？

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

根据需要修改该列。现在它正在A列你可以把它的参数来询问用户，就像第二个代码

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