Question

我最近开始工作，我们不时有任务要从许多excel文件中提取数据，但是，它们足够好，总是可以以相同的方式格式化数据，从A5：I5开始，直到文件包含数据的行数不同

这是一个宏，它打开文件夹中的每个Excel文件，从A5：I5向下获取数据，并将其粘贴到单独的文档中。

问题是我要合并的某些文件格式不同，我的代码无法正确处理它们。一些文件的底部只有一行，这导致需要TEXTbtm和删除空行部分

但是，某些文件的数据中有空行，并且当前代码的结构方式使我错过了第一个空行下方的所有数据。

/ ProcessFiles：

Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook

'Sets the folder containing files
Pathname = ActiveWorkbook.Path & "\Lists\"
Filename = Dir(Pathname & "*.xls")

'This part loops through all excelfiles in Lists and executes DoWork
Application.ScreenUpdating = False
Do While Filename <> ""
    Set wb = Workbooks.Open(Pathname & Filename)
    DoWork wb


    wb.Close SaveChanges:=True
    Filename = Dir()
Loop

'After importing the data, this clears up any empty rows, from 1-5000
'This part is quite slow, but it works
Workbooks.Open Filename:="C:\Users\Computer\Desktop\NAME\Folder\Main.xlsx"
Application.ScreenUpdating = True
Range("A1:I5000").Select
Dim iCounter As Long
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
For iCounter = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(iCounter)) = 0 Then
Selection.Rows(iCounter).EntireRow.Delete
End If
Next iCounter
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With



'This part removes the rows with only TEXTbtm written in the first cell
'This happens as some files have only one row, and the xlDown in DoWork 
'then grabs blank rows at the bottom, including these.
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:I1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$I$3").AutoFilter Field:=1, Criteria1:="TEXTbtm"
Range("A1:I1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.DisplayAlerts = False
Selection.Delete Shift:=xlUp
Application.DisplayAlerts = True
Range("A1:A1").Select

End Sub

/ DoWork：

Sub DoWork(wb As Workbook)
With wb

'selects A5:I5 and marks the underlying rows as well
 Range("A5:I5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

'Pastes the data into a file called Main, and selects the first empty row
Workbooks.Open Filename:="C:\Users\Computer\Desktop\NAME\Makro\Main.xlsx"
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select

'clears what is copied, and closes the file
Application.CutCopyMode = False
ActiveWorkbook.Close True



End With
End Sub

Answer 1

您可以使用以下内容代替Range(Selection, Selection.End(xlDown)).Select：

Dim lRow As Long
lRow = Cells.Find("*", Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious).Row

lRow =最后一行的数目

Range(Cells(1,1), Cells(lRow, 9)).Select

已编辑：缺少括号

在Excel中合并文件时出现空白行

1 个答案: