VBA从一个打开的工作簿复制

我有一个很小的问题，很简单的事情（显然）在VBA中。 我有两个工作簿。 第一个是跟踪器，保存在我的电脑上。 第二个是我每天收到的文件，我永远不会保存。 这第二个Excel文件可以有不同的名称，因此我不能在我的代码中有一个名称。 我需要从第二个Excel复制一系列单元格到我的跟踪器。 这是我有和不工作（当我操作命令button时没有任何反应）：

Sub OpenClose_Click() Dim i As Long Dim Filename As String Dim CellRange As String Dim wbkCur As Workbook Dim wbkNew As Workbook Set wbkCur = Workbooks("tracker") Filename = "C:\Users\tracker.xlsm" Set wbkNew = Workbooks.Open(Filename:=Filename) wbkNew.Worksheets("Info").Range("D8").Value=wbkCur.Worksheets("Data").Range("A2").Value wbkNew.Close SaveChanges:=True End Sub 

Answer 1

最简单的事情可能是使用FileDialog中的文件选取器，特别是如果第二个工作簿不一致。

 Sub OpenClose_Click() 'Create a variable to hold the path Dim wbkNewPath As String 'Select the file MsgBox ("Please choose location of file to be imported:") With Application.FileDialog(msoFileDialogOpen) .Show If .SelectedItems.Count = 1 Then wbkNewPath = .SelectedItems(1) End If End With 'Cancel will return vbNullString, so end the procedure If wbkNewPath = vbNullString Then End 'New workbook variables Dim wbkNew As Workbook Set wbkNew = Workbooks.Open(wbkNewPath) Dim wbkNewInfo As Worksheet Set wbkNewInfo = wbkNew.Sheets("Info") 'Create variables for current workbook Dim wbkCur As Workbook Set wbkCur = ThisWorkbook Dim wbkCurData as worksheet Set wbkCurData = wbkCur.Sheets("Data") 'Copy Data wbkNewInfo.Range("D8").Value = wbkCurData.Range("A2").Value wbkNew.Close SaveChanges:=True End Sub 

Answer 2

我从我的一个项目中复制了这个，做了一些closures。 我每天从CSV文件捕获订单，并在主电子表格中保存这些订单的清单，直到这些订单的处理完成。 这可能有点矫枉过正，但它应该做你需要的一切，并帮助你使过程更健壮。 您可以添加一行到您的命令button单击事件：

 Global Const AppName = "DailyMacro.xlsm" Sub Command1_Click() call ImportOrders End Sub Public Sub ImportOrders() Dim iFile As String, WorkbookName As String, ValidFile As Boolean, Path As String Application.ScreenUpdating = False '--dialog box to select today's file iFile = ImportFilename() ValidFile = True If iFile <> "" Then WorkbookName = StripPath(iFile) If ConfirmExcelFile(WorkbookName) Then Workbooks(WorkbookName).Activate With Worksheets(1) .Activate '--verify correct file type (depends on your needs) If Not (.Range("A1").Text = "H" And .Range("B1").Text = "PO") Then ValidFile = False 'not a valid file Else '--last row in column 'c' LR = LastRow(Worksheets(1).Name, "C") If LR < 2 Then ValidFile = False End If '--copy over today's data If ValidFile = True Then .Range("A2:AE" & LR - 1).Copy End With If ValidFile = True Then Workbooks(AppName).Activate With Worksheets(oFile) .Activate '--last row of existing data LR = LastRow(oFile, "C") '--append new rows to end .Range("A" & LR + 1).Select ActiveSheet.Paste Application.CutCopyMode = False End With Else MsgBox "Import file wrong format or empty. Please check and try again.", vbCritical, "ERROR" End If End If Workbooks(WorkbookName).Close End If Application.ScreenUpdating = True End Sub Private Function ImportFilename() As String Dim fName As String, fTitle As String, fFilter As String, LR As Long fTitle = "Please choose a file to open" fFilter = "Comma Separated Value *.csv* (*.csv*)," fName = Application.GetOpenFilename(Title:=fTitle, fileFilter:=fFilter) If fName = "False" Then MsgBox "No file selected.", vbExclamation, "Sorry!" Exit Function Else Workbooks.Open Filename:=fName ImportFilename = fName End If End Function Function StripPath(Filename) As String Dim X As Integer, NewName As String, saveName As String X = InStrRev(Filename, "\") If X <> 0 Then saveName = Mid(Filename, X + 1, Len(FileName)) End If StripPath = saveName End Function Function ConfirmExcelFile(Filename As String) As Boolean On Error GoTo BadFile 'confirm that we have valid excel file If Workbooks(Filename).Worksheets.Count > 0 Then 'now check to see if there is any data contained With Workbooks(Filename).Worksheets(1) If LastRow(.Name, "C") > 2 Then ConfirmExcelFile = True Exit Function Else MsgBox "Selected file does not contain data.", vbExclamation, "Error!" Exit Function End If End With End If BadFile: MsgBox "Selected file is not compatible.", vbExclamation, "Error!" End Function Function LastRow(Tabname As String, Col As String) As Long With Worksheets(Tabname) LastRow = .Cells(Rows.Count, Col).End(xlUp).Row End With End Function