我正在创建一个代码,它将帮助我将一个文件夹中的不同文件合并到一个唯一的电子表格中。 (输出应为平面文件,其中包含所有电子表格中的所有信息。)
所有电子表格的列数将相同,但是行数可能会有所不同。也就是说,行数应该是动态的。 (不过,以防万一,我想从源代码中对行和列进行二维编码。)
我只能编写一个特定的范围,但是在粘贴时,数据中有几个空白(在新创建的电子表格中复制的每个电子表格之间)。
关于从源代码对所有行和列进行动态编码并将其粘贴到新的电子表格中而没有任何空白行的建议吗?
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim wb As Workbook, ws As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
' Change this to the path\folder location of your files.
MyPath = "C:\Users\Dianear\Desktop\Test"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not wb Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With wb.Worksheets(1)
Set sourceRange = .Range("A1:AA15741")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= ws.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= ws.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
ws.Columns.AutoFit
wb.Close savechanges:=False
GoTo ExitTheSub
Else
' Set the destination range.
Set destrange = ws.Range("A" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
wb.Close savechanges:=False
End If
Next FNum
ws.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
答案 0 :(得分:0)
这是一种可能的解决方案:
Option Explicit
Sub test()
Dim ws As Worksheet
Dim LastColumn As Long, LastRow As Long, MaxRow As Long, i As Long
Dim rng As Range
For Each ws In ThisWorkbook.Worksheets '<- Loop sheets
With ws
MaxRow = 0
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column '<- Find last column of row 1
For i = 1 To LastColumn '<- Loop from column 1 to last column
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row '<- Find last row of column i
If MaxRow < LastRow Then '<- Check if max row if smallers than last row
MaxRow = LastRow '<- if max row is small that last row, max row get the value of last row
End If
Next i
Set rng = .Range(Cells(1, 1), Cells(MaxRow, LastColumn)) '<- Set the range to be copy. range if from A1 to last column last row
End With
Next ws
End Sub