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