Question

我有一个很小的大问题，在VBA中做一个非常简单的事情（显然）。我有两本工作簿。第一个是跟踪器，保存在我的电脑上。第二个是我每天收到的文件，我从未保存过。第二个excel文件可以有不同的名称，因此我的代码中没有名称。我需要将第二个excel中的一系列单元格复制到我的跟踪器中。这就是我拥有和不起作用（当我操作命令按钮时没有任何反应）：

  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

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

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

从打开的工作簿中复制VBA

2 个答案: