我有一个像这样的工作表：
Column A < - - - -
A |
B - - - - Range A30:A39
C |
|
< - - - -
Next Line
Text way down here
我正在使用此代码删除范围A30：39中的空单元格。该范围位于＆＃39; Next Line＆＃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
答案 0 :(得分：0)
根据需要修改列。现在它正在处理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