Question

我这里有一个宏代码，其中将编码数据保存到同一工作簿中的另一个工作表中。但我想在这个宏中进行一些修改，我希望编码数据保存到另一个工作簿，这是我的代码：

Sub RoundedRectangle1_Click()
Dim i, lastrow As Long
If ActiveSheet.Range("d6") = "" Or ActiveSheet.Range("g6") = "" Or ActiveSheet.Range("c9") = "" Then
MsgBox "Please complete all fields!"
Exit Sub
End If

lastrow = Sheets("database").Cells(Cells.Rows.Count, 2).End(xlUp).Row + 1
i = 9
Do While Cells(i, 3) <> "" And i < 29
Sheets("Database").Cells(lastrow, 2) = ActiveSheet.Range("g6") ' Date
Sheets("Database").Cells(lastrow, 3) = ActiveSheet.Range("d6") ' Ref
Sheets("Database").Cells(lastrow, 4) = ActiveSheet.Cells(i, 3) ' Code
Sheets("Database").Cells(lastrow, 5) = ActiveSheet.Cells(i, 4) ' Description
Sheets("Database").Cells(lastrow, 6) = ActiveSheet.Cells(i, 5) ' U/M
Sheets("Database").Cells(lastrow, 7) = ActiveSheet.Cells(i, 6) ' Qty
Sheets("Database").Cells(lastrow, 8) = ActiveSheet.Cells(i, 7) ' Price
Sheets("Database").Cells(lastrow, 9) = "IN" ' Transaction
i = i + 1
lastrow = lastrow + 1
Loop
MsgBox "Saved Succesfully!"
ThisWorkbook.Save
Call RoundedRectangle2_Click
End Sub

Answer 1

也许，代码就像这样..

Sub RoundedRectangle1_Click()
Dim i As Long, lastrow As Long, n As Long
Dim vResult()
Dim myWs As Worksheet

Set myWs = ThisWorkbook.Sheets("Database")

If ActiveSheet.Range("d6") = "" Or ActiveSheet.Range("g6") = "" Or ActiveSheet.Range("c9") = "" Then
MsgBox "Please complete all fields!"
Exit Sub
End If

'lastrow = Sheets("database").Cells(Cells.Rows.Count, 2).End(xlUp).Row + 1
i = 9
Do While Cells(i, 3) <> "" And i < 29
    n = n + 1
    ReDim Preserve vResult(1 To 8, 1 To n)
    vResult(1, n) = ActiveSheet.Range("g6") ' Date
    vResult(2, n) = ActiveSheet.Range("d6") ' Ref
    vResult(3, n) = ActiveSheet.Cells(i, 3) ' Code
    vResult(4, n) = ActiveSheet.Cells(i, 4) ' Description
    vResult(5, n) = ActiveSheet.Cells(i, 5) ' U/M
    vResult(6, n) = ActiveSheet.Cells(i, 6) ' Qty
    vResult(7, n) = ActiveSheet.Cells(i, 7) ' Price
    vResult(8, n) = "IN" ' Transaction
    i = i + 1

Loop

Dim wb As Workbook
'chage workbook name as  your workbook.name
Set wb = Workbooks("another.xlsx")
With wb.Sheets("Database")
    .Range("b" & Rows.Count).End(xlUp)(2).Resize(n, 8) = WorksheetFunction.Transpose(vResult)
End With
myWs.Range("b" & Rows.Count).End(xlUp)(2).Resize(n, 8) = WorksheetFunction.Transpose(vResult)

MsgBox "Saved Succesfully!"
ThisWorkbook.Save
Call RoundedRectangle2_Click
End Sub

将编码数据保存到另一个工作簿

1 个答案: