Excel VBA-修改代碼，以便將數據從「發票」工作表傳輸至「銷售工作簿」工作表，然後保存至其他工作簿

Question

我有此代碼，它將數據從「發票」工作表發送到「銷售工作簿」工作表，但經過考慮後認爲將數據完全發送到不同的工作簿會是有益的。我將如何使用下面的代碼來實現這個（因爲它花了我很長時間纔得到這個！）。這是代碼-這是原始問題。現在已經完全解決，並在下面更新 -

下面的代碼現在可用。要解決的最後一個問題是，複製的數據也複製到空項目行上。我找到了一個簡單的解決方案，我將這裏的圖片下面的代碼複製。它基本上是一個自動運行的vba代碼，如果某個單元格中沒有數據，它將刪除一行。謝謝您的幫助。我感覺無敵！

Sub sendtosales() 
Dim WB As Workbook '''! 
Dim CurrentWB As Workbook '''! 
Dim WBLoc As String '''! 
Dim rng As Range 
Dim i As Long 
Dim a As Long 
Dim rng_dest As Range 
Application.ScreenUpdating = False 
WBLoc = "C:\Salestracker.xlsm" '''! Location of the workbook, trimmed down for public view 
Set CurrentWB = Excel.ThisWorkbook '''! 
Set WB = Workbooks.Open(WBLoc) '''! Opens the workbook 
i = 1 
Set rng_dest = WB.Sheets("Salestracker").Range("D:F") '''! Change Sheets() to whichever sheet you want to use 

' Find first empty row in columns D:F on sheet Sales Book 
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0 
    i = i + 1 
Loop 

'Copy range A23:D27 on sheet Invoice to Variant array 
Set rng = CurrentWB.Sheets("Invoice").Range("A23:D27") '''! 

' Copy rows containing values to sheet Sales Book 
For a = 1 To rng.Rows.Count 
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then 
    rng_dest.Rows(i).Value = rng.Rows(a).Value 
    With WB.Sheets("Salestracker") '''! Change Sheets() to whichever sheet you want to use 
    'Copy Invoice number 
    .Range("B" & i).Value = CurrentWB.Sheets("Invoice").Range("C18").Value '''! 
    'Copy Date 
    .Range("A" & i).Value = CurrentWB.Sheets("Invoice").Range("C15").Value '''! 
    'Copy Company name 
    .Range("C" & i).Value = CurrentWB.Sheets("Invoice").Range("A7").Value '''! 
    End With '''! 
    i = i + 1 
End If 
Next a 

WB.Close savechanges:=True '''! This wil close the Workbook and save changes 

Set WB = Nothing '''! Cleaning memory 
Set CurrentWB = Nothing '''! Cleaning memory 
Application.ScreenUpdating = True 

End Sub 

下面是刪除那些在某一小區中沒有數據行的代碼，F在我區分

Sub killemptyF() 
On Error Resume Next 
Columns("F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
End Sub 

這裏是代碼自動運行此模塊無論何時打開工作簿 -

Sub Auto_Run() 
Run ("killemptyF") 
End Sub 

Answer 1

像這樣的東西應該工作。我已添加/編輯的所有內容均標有'''!。

Sub sendtosales() 
Dim WB as Workbook '''! 
Dim CurrentWB as Workbook '''! 
Dim WBLoc as String '''! 
Dim rng As Range 
Dim i As Long 
Dim a As Long 
Dim rng_dest As Range 
Application.ScreenUpdating = False 
WBLoc = "C:\Documents\Salestracker.xlsm" '''! Location of the workbook 
Set CurrentWB = Excel.ThisWorkbook '''! 
Set WB = Workbooks.Open(WBLoc) '''! Opens the workbook 
i = 1 
Set rng_dest = WB.Sheets(1).Range("D:F") '''! Change Sheets() to whichever sheet you want to use 

' Find first empty row in columns D:F on sheet Sales Book 
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0 
    i = i + 1 
Loop 

'Copy range A23:D27 on sheet Invoice to Variant array 
Set rng = CurrentWB.Sheets("Invoice").Range("A23:D27") '''! 

' Copy rows containing values to sheet Sales Book 
For a = 1 To rng.Rows.Count 
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then 
    rng_dest.Rows(i).Value = rng.Rows(a).Value 
    With WB.Sheets(1) '''! Change Sheets() to whichever sheet you want to use 
    'Copy Invoice number 
    .Range("B" & i).Value = CurrentWB.Sheets("Invoice").Range("C18").Value '''! 
    'Copy Date 
    .Range("A" & i).Value = CurrentWB.Sheets("Invoice").Range("C15").Value '''! 
    'Copy Company name 
    .Range("C" & i).Value = CurrentWB.Sheets("Invoice").Range("A7").Value '''! 
    End With '''! 
    i = i + 1 
End If 
Next a 

WB.Close savechanges:=True '''! This wil close the Workbook and save changes 

Set WB = Nothing '''! Cleaning memory 
Set CurrentWB = Nothing '''! Cleaning memory 
Application.ScreenUpdating = True 

End Sub