我需要从特定文件夹中的多个文件复制并粘贴到主文件中。所有文件都有一个名为“分析”的工作表,行可变,列不变。我需要从所有文件中复制工作表“分析”A4:AB 并粘贴到工作簿中名为“评估”的工作簿中,名为“评估”G2:AH,一个在另一个之下。我有下面的代码,它有效但不再有效,我不知道为什么。你能帮忙吗?
Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim lastRow As Long
Const strPath As String = "V:\Trade Marketing\Trade Finance\2021\Projects\Evaluation\Analysis\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
lastRow = .Sheets("Analysis").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Analysis").Range("A4:AB" & lastRow).Copy wkbDest.Sheets("Evaluations").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub
答案 0 :(得分:0)
Option Explicit
Sub AnalysisBackup()
Const swbPath As String _
= "V:\Trade Marketing\Trade Finance\2021\Projects\Evaluation\Analysis\"
Const swbPattern As String = "*.xls*"
Const sName As String = "Analysis"
Const sCols As String = "A:AB"
Const sFirstRow As Long = 4
Const dName As String = "Evaluations"
Const dFirst As String = "G2"
Dim swbName As String: swbName = Dir(swbPath & swbPattern)
If swbName = "" Then Exit Sub ' no file found
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
Dim cCount As Long: cCount = dws.Columns(sCols).Columns.Count
Dim dirrg As Range: Set dirrg = dws.Range(dFirst).Resize(, cCount)
Dim drrg As Range ' Destination First Row Range
Dim dlCell As Range ' Destination Last Cell
Set dlCell = dirrg.Resize(dws.Rows.Count - dirrg.Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then
Set drrg = dirrg
Else
Set drrg = dirrg.Offset(dlCell.Row - dirrg.Row + 1)
End If
Dim swb As Workbook ' Source Workbook
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Source Range
Dim slCell As Range ' Source Last Cell
Dim srCount As Long ' Source Range Rows Count
Dim drg As Range ' Destination Range
Application.ScreenUpdating = False
Do While swbName <> ""
Set swb = Workbooks.Open(swbPath & swbName)
Set sws = Nothing
On Error Resume Next
Set sws = swb.Worksheets(sName)
On Error GoTo 0
If Not sws Is Nothing Then
Set slCell = Nothing
With sws.Rows(sFirstRow).Columns(sCols)
Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If Not slCell Is Nothing Then
srCount = slCell.Row - .Row + 1
Set srg = .Resize(srCount)
Set drg = drrg.Resize(srCount)
drg.Value = srg.Value
Set drrg = drrg.Offset(srCount)
'Else ' empty source range
End If
End With
'Else ' source worksheet does not exist
End If
swb.Close SaveChanges:=False
swbName = Dir
Loop
'dwb.Save
Application.ScreenUpdating = True
MsgBox "Analysis backup created.", vbInformation, "Analysis Backup"
End Sub