Excel VBA-修改代码，以便从＆＃39; Invoice＆＃39;表到销售书＆＃39;表单保存到不同的工作簿

Question

我有这个代码，它发送来自＆＃39;发票＆＃39;表到销售书＆＃39;表，但考虑后认为将数据完全发送到不同的工作簿是有益的。我将如何使用下面的代码实现这一点（因为我花了很长时间才能实现这一目标！）。这是代码 - 这是原始问题。它现在已完全解决并在下面更新 -

以下代码现在有效。要解决的最后一个问题是复制的数据也会复制空项目行。我找到了一个简单的解决方案，我将在这里复制图片下面的代码。它基本上是一个自动运行的vba代码，如果某个单元格中没有数据，它会删除一行。谢谢您的帮助。我觉得无敌！

modelpackage

以下是删除某个单元格中没有数据的行的代码，在我的情况下为F -

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

以下是每当打开工作簿时自动运行此模块的代码 -

Sub killemptyF()
On Error Resume Next
Columns("F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
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