Excel宏从两个单元格从一个工作簿中的两个单元格复制到另一个工作簿

Question

＆＃13;

＆＃13;

Sub buildtimetable()
Dim FolderName As String
Dim Fname As String
FolderName = "C:\New folder\test"
    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

＆＃13;

＆＃13;

＆＃13;

我正在尝试在我的目录中打开一个文件，并将第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 folder\test\"
    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 folder\test"
    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