[英]VBA copy from an open workbook
I have a small big problem with a very simple thing to do (apparently) in VBA. 我在VBA中要做一个非常简单的事情(看来)有一个小问题。 I have two workbooks.
我有两个工作簿。 The first one is a tracker, saved on my computer.
第一个是保存在我计算机上的跟踪器。 The second one is a file I receive daily, which I never save.
第二个是我每天收到的文件,我从未保存过。 This second excel file can have different names, therefore I cannot have a name in my code.
第二个excel文件可以使用不同的名称,因此我的代码中不能使用名称。 I need to copy a range of cells from the second excel to my tracker.
我需要将范围广泛的单元格从第二个Excel复制到跟踪器。 This is what I have and doesn't work (nothing happens when I action the command 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
The easiest thing is probably going to be using a file picker from FileDialog, especially if your second workbook is not consistent. 最简单的事情可能是使用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
I copied this from one of my projects that does something close. 我从一个做得很接近的项目中复制了此内容。 I'm capturing orders from a CSV file daily and keeping a list of those orders in the master spreadsheet until the processing is completed for those orders.
我每天都会从CSV文件中捕获订单,并将这些订单的列表保存在主电子表格中,直到这些订单的处理完成为止。 This might be a little overkill, but it should do everything you need and help you make the process more robust.
这可能有点矫kill过正,但是它应该做您需要的所有事情,并帮助您使过程更强大。 You can add a line into your command button click event:
您可以在命令按钮单击事件中添加一行:
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.