我有代码将多个excel工作簿合并在一起，并将数据更新到另一个工作簿＆＃34; Master＆＃34;但是，当它将数据粘贴到master中时，它会在插入之前留下许多空行。数据表。
我尝试了各种发布的解决方案，但是，当我合并新代码时，它失败了。我可以使用一些帮助来修改我的代码，以便在更新数据之前处理删除表中插入的空白行。
请参阅&& 39;＆gt;＆gt;＆gt;＆gt;＆gt;＆gt;＆gt;＆gt;＆gt;＆gt;在代码中标记。
Public Function MergeMultipleSheets()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim myBook As Workbook, wbMaster As Workbook
Dim BaseWks As Worksheet, ws As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim rng As Range, SearchValue As String
Dim FilterField As Integer, RangeAddress As String
Dim ShName As Variant, ShNames As Variant, RwCount As Long, nName As Variant
Dim nFilter As String
Dim currentrow As Long
Dim LastRow As Long
MyPath = ThisWorkbook.Sheets("Data Input").Range("B1")
' ShNames = Array("ProjSum", "FinSum", "CommSum", "InvPlan", "ResPlan_Data")
ShNames = Array("ProjSum", "ResPlan_Data")
Set wbMaster = ActiveWorkbook
'**********************************************************
'Merge data into existing worksheets in this workbook
'**********************************************************
' Add a slash after MyPath if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
'FilesInPath = Dir(MyPath & "week*.xl*")
nFilter = ThisWorkbook.Sheets("Data Input").Range("B2")
If nFilter = "" Or FilesInPath = "" Then
FilesInPath = Dir(MyPath & "*.xl*")
End If
' Fill the myFiles array with the list of Excel files in the
' folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Change application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Clear data from summary worksheets
For Each ShName In ShNames
Set rng = Nothing
On Error Resume Next
Set rng = wbMaster.Worksheets(ShName).UsedRange
On Error GoTo 0
If Not rng Is Nothing Then
'Don't delete header labels in the first row
Set rng = rng.Offset(1, 0)
End If
Next
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set myBook = Nothing
On Error Resume Next
Set myBook = Workbooks.Open(MyPath & MyFiles(FNum), UpdateLinks:=0)
'**************************************************************************************************
'Removes unused Named Ranges from Name Manager from the Various JC files to prevent error dialogs.
'**************************************************************************************************
For Each nName In Names
If InStr(1, nName.RefersTo, "#REF!") > 0 Then
nName.Delete
End If
If InStr(1, nName.RefersTo, "https://") > 0 Then
nName.Delete
End If
Next nName
On Error GoTo 0
If Not myBook Is Nothing Then
For Each ShName In ShNames
Set ws = Nothing
On Error Resume Next
Set ws = myBook.Worksheets(ShName)
On Error GoTo 0
'****************************************************************************************************************************
'Calls function to update ResPlan in active workbook
'Executes Updating of the ResPlan data to proper format for extraction of data in correct format
'****************************************************************************************************************************
If ShName = "ResPlan_Data" Then
Call UnpivotResPlan
myBook.Save
End If
'**************************************************
'Updates template data per shName
'*************************************************
'>>>>>>>>>
If Not ws Is Nothing Then
Set BaseWks = wbMaster.Worksheets(ShName)
Set sourceRange = ws.UsedRange
'Exclude header labels
Set rng = sourceRange.Offset(1, 0).Resize(sourceRange.Rows.Count - 1, sourceRange.Columns.Count)
rng.ClearContents
Dim rngBlanks As Excel.Range
With wbMaster.Worksheets(ShName).ListObjects("Res_Plan_Data")
On Error Resume Next
Set rngBlanks = Intersect(.DataBodyRange, .ListColumns("New").Range).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlanks Is Nothing Then
rngBlanks.Delete
End If
End With
RwCount = rng.Rows.Count
rnum = BaseWks.Cells(BaseWks.Rows.Count, 1).End(xlUp).Row + 1
BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
= myBook.Name
BaseWks.Cells(rnum, "B").Resize(RwCount, rng.Columns.Count).Value = rng.Value
End If
Next
' Close the workbook without saving.
myBook.Close savechanges:=True
End If
' Open the next workbook.
Next FNum
' Set the column width in the new workbook.
BaseWks.Columns.AutoFit
'Prepares Salary Detail for Updating.
Call UnpivotSalaryDetail
End If
Call Reset
' ActiveWorkbook.Model.Refresh
If Worksheets("Resplan_Data").Visible = True Then
Worksheets("Resplan_Data").Visible = False
End If
MsgBox "Update completed!"
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Function
Sub ClearBlankCellsInColumnNew()
Dim rngBlanks As Excel.Range
With Worksheets("ResPlan_Data").ListObjects("Res_Plan_Data")
On Error Resume Next
Set rngBlanks = Intersect(.DataBodyRange, .ListColumns("New").Range).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlanks Is Nothing Then
rngBlanks.Delete
End If
End With
End Sub
答案 0 :(得分：0)
不确定这是否是你所追求的但它会删除A列中有空白单元格的所有行
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
快速浏览Columns("A:A")是目标列，更改字母并根据需要添加数字或变量。 .SpecialCells(xlCellTypeBlanks)是它将定位的单元格，在这种情况下，它将是空白单元格（记录宏并按Ctrl + G以获取您需要的任何变体）。最后.EntireRow.Delete将删除目标行。
因此它将在A列中查找，如果A列中有任何空白单元格，它将删除该行。
希望这有帮助，如果你需要任何澄清的话，请留下评论