Excel宏，用于从一个工作簿中的两张工作表中的两个单元格复制到另一个工作簿

Question

Sub buildtimetable()
Dim FolderName As String
Dim Fname As String
FolderName = "C:New foldertest"
    If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
    Fname = Dir(FolderName & "*.xls")
    'loop through the files
    Do While Len(Fname)
        With Workbooks.Open(FolderName & Fname)
    Dim w As Workbook
    Dim lastrow As Long
lastrow = Range("A300000").End(xlUp).Row
ActiveWorkbook.Sheets(2).Select
Range("K2").Select
Selection.Copy
Workbooks("TimeTable.xlsx").Activate
         Sheets(1).Rows( _
             Sheets(1).Range("B" & Rows.Count).End(xlUp).Row + 1 & _
             ":" & _
             Sheets(1).Range("B" & Rows.Count).End(xlUp).Row + 1 _
             ).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
Workbooks(Fname).Activate
ActiveWorkbook.Sheets(3).Select
Range("K2").Select
Selection.Copy
Workbooks("TimeTable.xlsx").Activate
         Sheets(1).Rows( _
             Sheets(1).Range("C" & Rows.Count).End(xlUp).Row + 1 & _
             ":" & _
             Sheets(1).Range("C" & Rows.Count).End(xlUp).Row + 1 _
             ).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
        End With
' go to the next file in the folder
        Fname = Dir
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.Close
    Loop
End Sub

我正在尝试打开目录中的一个文件，并将工作表2和3中单元格K2中的值复制到桌面上打开的新工作簿中。这个代码不起作用，我似乎不知道哪里出了问题。大多数情况下，在指定要选择/激活的工作簿时遇到问题。

Answer 1

代码：

Sub buildtimetable()
Dim FolderName As String
Dim Fname As String
Dim w As Worksheet
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w = Workbooks("TimeTable.xlsx").Sheets(1)
FolderName = "C:New foldertest"
    Fname = Dir(FolderName & "*.xls")
    'loop through the files
    Do While Len(Fname)
        With Workbooks.Open(FolderName & Fname)
            Set w1 = .Sheets(2)
            Set w2 = .Sheets(3)
            
            w1.Range("K2").Copy
            
            w.Range("B" & w.Range("B1").End(xlDown).Row + 1).PasteSpecial _
                                                              Paste:=xlPasteValues, Operation:=xlNone, _
                                                              SkipBlanks:=False, Transpose:=False
                                                              
            Application.CutCopyMode = False
            
            w2.Range("K2").Copy
    
            w.Range("C" & w.Range("C1").End(xlDown).Row + 1).PasteSpecial _
                                                              Paste:=xlPasteValues, Operation:=xlNone, _
                                                              SkipBlanks:=False, Transpose:=False
             
            Application.CutCopyMode = False
        
        End With
' go to the next file in the folder
        Fname = Dir
        
        Application.DisplayAlerts = False
        
        Application.EnableEvents = False
        
        .Close
    Loop
End Sub

Answer 2

我正在尝试，似乎正在工作，但副本将它放在了另一个excel文件中的错误位置，并且它没有正确地复制所有内容或向下移动行。

Sub buildtimetable()
Dim FolderName As String
Workbooks.Open ("C:TimeTable.xlsx")
Dim Fname As String
    
    FolderName = "C:New foldertest"
    If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
    Fname = Dir(FolderName & "*.xls")
    'loop through the files
    Do While Len(Fname)
    With Workbooks.Open(FolderName & Fname)
    Dim lastrow As Long
  
lastrow = Range("B300000").End(xlUp).Row
'Time
Workbooks(Fname).Worksheets(2).Range("K2").Copy
Workbooks("TimeTable.xlsx").Worksheets(1).Range("B" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
Workbooks(Fname).Worksheets(3).Range("K2").Copy
Workbooks("TimeTable.xlsx").Worksheets(1).Range("C" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
'Max Min value a
Workbooks(Fname).Worksheets(1).Range("O2").Copy
Workbooks("TimeTable.xlsx").Worksheets(1).Range("D" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
Workbooks(Fname).Worksheets(3).Range("N2").Copy
Workbooks("TimeTable.xlsx").Worksheets(1).Range("E" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
'Max Min value b
Workbooks(Fname).Worksheets(2).Range("P2").Copy
Workbooks("TimeTable.xlsx").Worksheets(1).Range("F" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
Workbooks(Fname).Worksheets(3).Range("M2").Copy
Workbooks("TimeTable.xlsx").Worksheets(1).Range("G" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
        End With
        
        
' go to the next file in the folder
Fname = Dir
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.Close
    Loop
End Sub