我有一個作業表 (sheet2)，其中包含一個 vlookup 函式，可以更改某些單元格中的值以重繪 資料。我想復制任何更改的值以粘貼到新作業簿中。
Sub Copy_file()
Dim xWs As Worksheet
Dim Rng As Range
Set Rng = Range("C6:M124")
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
Rng.Copy
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteValues
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub
所以，上面的代碼實際上運行良好。但是每次宏運行時，它總是一遍又一遍地創建一個新的作業簿。
我需要修改它，以便我可以添加一個具有特定名稱的新作業簿，并且僅當宏第一次運行時，復制的資料才會粘貼到 sheet1 中。然后將復制的資料粘貼到單個作業簿中的下一個作業表（例如 Sheet2、sheet3、sheet4 等）中。
uj5u.com熱心網友回復：
嘗試：
Sub Copy_file()
Application.ScreenUpdating = False
Dim xWs As Worksheet
Static WB As Workbook ' static variables stores its values between proc calls
If WB Is Nothing Then ' check if a certain workbook exists. if no, create it
Set WB = Workbooks.Add
Else
WB.Worksheets.Add after:=WB.Sheets(WB.Sheets.Count) ' create the next WS
End If
Set xWs = ActiveSheet
ThisWorkbook.Sheets("Sheet2").Range("C6:M124").Copy
With xWs.Cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
請嘗試下一個代碼：
Sub Copy_file()
Dim xWs As Worksheet, Rng As Range, wb As Workbook, wsMark As Worksheet
Dim wbFullName As String, wbName As String, lastR As Long
wbName = "MyWorkbook.xlsx"
wbFullName = ThisWorkbook.Path & "\" & wbName
Set Rng = Range("C6:M124") 'the range is set in the active workbook
'if the one keeping the code, please state it
'and the range will be fully qualified
If dir(wbName) = "" Then 'if the necessary workbook does not exist
Set wb = Application.Workbooks.Add 'create it
wb.saveas wbName 'name the newly created workbook
Set wsMark = wb.Sheets(wb.Sheets.count)
wsMark.Name = "UsedSheets" 'name the last sheet keeping copying order
End If
If wb Is Nothing Then 'if not created above, but exists:
On Error Resume Next
Set wb = Workbooks(wbName) 'check if it is open
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
On Error GoTo 0
End If
'if not open, open it:
If wb Is Nothing Then
Set wb = Workbooks.Open(wbFullName)
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
End If
lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
If lastR > 1 Then
If CLng(wsMark.Range("A" & lastR).value) < (wb.Sheets.count - 2) Then
Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value 1))
wsMark.Range("A" & lastR 1).value = xWs.Index
Else
Set xWs = wb.Sheets.Add(Before:=wsMark)
wsMark.Range("A" & lastR 1).value = xWs.Index
End If
Else
Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR 1).value = 1
End If
Rng.copy
With xWs.cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End Sub
編輯：
請測驗下一個變體。它會在您第一次運行代碼時打開一個新作業簿并使用它直到您關閉它。完成復制程序后，您必須手動保存它...
Sub Copy_file()
Dim xWs As Worksheet, Rng As Range, wb As Workbook, wsMark As Worksheet
Dim wbFullName As String, wbName As String, lastR As Long
wbName = "MyWorkbook.xlsx"
wbFullName = ThisWorkbook.Path & "\" & wbName
Set Rng = Range("C6:M124")
If dir(wbName) = "" Then 'if the necessary workbook does not exist
Set wb = Application.Workbooks.Add 'create it
wb.saveas wbName 'name the newly created workbook
Set wsMark = wb.Sheets(wb.Sheets.count)
wsMark.Name = "UsedSheets" 'name the last sheet keeping copying order
End If
If wb Is Nothing Then 'if not created above, but exists:
On Error Resume Next
Set wb = Workbooks(wbName) 'check if it is open
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
On Error GoTo 0
End If
'if not open, open it:
If wb Is Nothing Then
Set wb = Workbooks.Open(wbFullName)
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
End If
lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
If lastR > 1 Then
If CLng(wsMark.Range("A" & lastR).value) < wb.Sheets.count - 1 Then
Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value 1))
wsMark.Range("A" & lastR 1).value = xWs.Index
Else
Set xWs = wb.Sheets.Add(Before:=wsMark)
wsMark.Range("A" & lastR 1).value = xWs.Index
End If
Else
Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR 1).value = 1
End If
Rng.copy
With xWs.cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End Sub
Sub Copy_file1()
Dim xWs As Worksheet, Rng As Range, wb As Workbook
Dim w As Workbook, wsMark As Worksheet, lastR As Long
Set Rng = Range("C6:M124") 'if active sheet belongs to the workbook keeping this code
'it should be adapted to fully qualify the range
If wb Is Nothing Then 'check if wb exists but it losts the reference because of an error:
For Each w In Workbooks 'iterate between open workbooks:
If w.Sheets(w.Sheets.count).Name = "UsedSheets" Then
Set wb = w
Set wsMark = wb.Worksheets("UsedSheets"): Exit For
End If
Next w
End If
'if wb does not exist:
If wb Is Nothing Then
Set wb = Application.Workbooks.Add 'open a new workbook and set it
Set wsMark = wb.Sheets(wb.Sheets.count) 'set the last sheet like the one to keep copying order
wsMark.Name = "UsedSheets"
End If
If left(Rng.Parent.Parent.Name, 4) = "Book" Then 'if, by mistake, the selection is done on a wb sheet:
MsgBox "The active sheet where ""Rng"" was set belongs to the workbook where to copy..." & vbCrLf & _
"It should be a mistake. Please, select the appropriate sheet!", vbInformation, "Wrong sheet selected.."
Exit Sub
End If
lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
If lastR > 1 Then 'for the first time (when wb has been created):
If CLng(wsMark.Range("A" & lastR).value) < wb.Sheets.count - 1 Then
Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value 1))
wsMark.Range("A" & lastR 1).value = xWs.Index
Else 'if is not the first copying time:
Set xWs = wb.Sheets.Add(Before:=wsMark)
wsMark.Range("A" & lastR 1).value = xWs.Index
End If
Else
Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR 1).value = 1
End If
Rng.copy
With xWs.cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/373154.html