Excel宏從兩個細胞由兩個片在一個工作簿複製到另一個

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

我想在我的目錄中打開一個文件，並從細胞K2在表2和3複製值一個我已經在桌面上打開的新工作簿。這段代碼不起作用，我似乎無法弄清楚我錯在哪裏。通常在指定選擇/激活哪個工作簿時遇到困難。

來源

2014-09-29 excelhelp

恰好是不工作怎麼辦？你看到了什麼錯誤？ – 2014-09-29 13:16:42

它不會將單元格值從K2複製到我的其他工作簿，而是從B2開始獲取相同編號的無盡行，並且一直持續到工作表的末尾。現在我試圖打開新的工作簿，粘貼，保存並關閉。然後重新打開舊的工作簿，轉到表3並重復。但這甚至聽起來非常低效，似乎根本不起作用。 – excelhelp 2014-09-29 15:05:56

我想如果你清理所有的Select和Activate語句，答案就會很清楚。您不需要選擇或激活工作簿/工作表/單元格以從中進行復制。只需使用完整的命令。例如：'Workbook.Worksheet.Range（...）。Copy' – 2014-09-29 15:23:37

代碼：

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

來源

2014-09-29 16:41:00

運行到最後一個無效或不合格的引用錯誤@ .close。 – excelhelp 2014-09-29 16:44:01

對不起。把它移動到'End With'行之前。 – 2014-09-29 16:47:13

失去了錯誤，但是當我運行時沒有任何反應 – excelhelp 2014-09-29 16:50:13

我想這一點，似乎是工作，但複製把它在其他錯誤的地方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

來源

2014-09-29 16:48:40 excelhelp

Excel宏從兩個細胞由兩個片在一個工作簿複製到另一個

回答

代碼：

相關問題