这是一段使用一些值(A1:C5)并将其粘贴到B列中的值的代码。显然,在A列中有文件名。
现在,简单地讲,我需要再准备一个内容块(B2:D13),并将其插入C列中。我试过了,但对我没有任何帮助。
Sub MergeCode1()
Dim BaseWks As Worksheet
Dim rnum As Long
Dim CalcMode As Long
Dim MySplit As Variant
Dim FileInMyFiles As Long
Dim Mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim SourceRcount As Long
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
BaseWks.Range("A1").Font.Size = 36
BaseWks.Range("A1").Value = "Please Wait"
rnum = 3
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Clear MyFiles to be sure that it not return old info if no files are found
MyFiles = ""
'Get the files, set the level of folders and extension in the code line below
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
'Level : 1= Only the files in the folder you select, 2 to ? levels of subfolders
'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3
' Work with the files if MyFiles is not empty.
If MyFiles <> "" Then
MySplit = Split(MyFiles, Chr(13))
For FileInMyFiles = LBound(MySplit) To UBound(MySplit)
Set Mybook = Nothing
On Error Resume Next
Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
On Error GoTo 0
If Not Mybook Is Nothing Then
On Error Resume Next
With Mybook.Worksheets(1)
Set sourceRange = .Range("A1:C5")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.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 >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
Mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MySplit(FileInMyFiles)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
Mybook.Close savechanges:=False
End If
Next FileInMyFiles
BaseWks.Columns.AutoFit
End If
ExitTheSub:
BaseWks.Range("A1").Value = "Ready"
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
非常感谢
未经测试,但应该差不多可以了:
Sub MergeCode1()
Dim BaseWks As Worksheet
Dim rnum As Long
Dim MySplit As Variant
Dim Mybook As Workbook
Dim src1 As Range, src2 As Range
Dim destrange As Range
Dim Rcount As Long
Dim f
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
BaseWks.Range("A1").Font.Size = 36
BaseWks.Range("A1").Value = "Please Wait"
rnum = 3
MyFiles = ""
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, _
FileFilterOption:=0, FileNameFilterStr:="")
If MyFiles <> "" Then
MySplit = Split(MyFiles, Chr(13))
For Each f In MySplit
Set Mybook = Workbooks.Open(f)
Set src1 = Mybook.Worksheets(1).Range("A1:C5")
Set src2 = Mybook.Worksheets(1).Range("G8:Z10")
'max # of rows to be added...
Rcount = Application.Max(src1.Rows.Count, src2.Rows.Count)
If rnum + Rcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
Mybook.Close savechanges:=False
Exit For
Else
BaseWks.Cells(rnum, "A").Resize(Rcount).Value = f
BaseWks.Cells(rnum, "B").Resize(src1.Rows.Count, _
src1.Columns.Count).Value = src1.Value
BaseWks.Cells(rnum, "B").Offset(0, src2.Columns.Count) _
.Resize(src2.Rows.Count, src2.Columns.Count).Value = src2.Value
rnum = rnum + Rcount
End If
Mybook.Close savechanges:=False
Next f
BaseWks.Columns.AutoFit
End If
BaseWks.Range("A1").Value = "Ready"
End Sub