Question

按照建议从超级细节历史模式中删除。

我的专业水平：十年前黑客攻击了一些相当复杂的对话框 - 多工作簿宏系统，经验丰富，但没有经过正式培训和生锈。

这个宏的复杂东西起作用;它的核心错误是它不会改变那个CurrentClientAnchor Range变量，这是Excel VBA中最基本的操作，无论我做什么。它会循环多次锚定在单元格A2上，正确地找到接下来应该成为CurrentClientAnchor的单元格（在真实数据上，A4，两个单元格向下），并且只要您给出，就可以从所选数据中完美地创建发票单它允许覆盖它刚刚创建的副本。如果我的特殊的最后一个记录例程破坏了某些东西，我会不会感到惊讶，但是手动单步执行，没有任何一个If子句运行。该程序正确地跨过它。 WhatsMyAnchor应该在最后一个Loop命令之前为4，但永远不会从2更改。

我知道实现我想要的唯一方法没有在代码中留下注释的化石是我写的第一个，将ClientsRange指定为Range over Range（“A2”，Cells（LastRow，1）））然后将所有内容放入For ... Next循环中。那个版本也只是在第一张唱片上反复出现。

请问，我以何种方式变得非常愚蠢？

Option Explicit
Sub FillOutInvoices()

Dim BilledDate As String
Dim ServiceYear As String
Dim ServiceMonth As String
Dim CompBasePath As String

Dim InvoiceTemplatePath As String
InvoiceTemplatePath = "H:\Comp\Comp Invoice BLANK PRINT COPY.xls"





'The info to change for each invoicing
'========================
'========================
CompBasePath = "H:\Comp\2014 Invoices\"
ServiceYear = "2014"
ServiceMonth = "September"
BilledDate = "02/01/2015"
'========================
'========================





Dim InvoiceFolder As String
InvoiceFolder = CompBasePath & ServiceYear & " " & ServiceMonth & " generated invoices" & "\"
If Dir(InvoiceFolder, vbDirectory) = vbNullString Then
  MkDir InvoiceFolder
End If
'Find the last used row on the sheet with a web recipe to speed things up
'and avoid arbitrary search windows.
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count

'We assume our first client is in A2
Dim CurrentClientAnchor As Range
Set CurrentClientAnchor = Range("A2")
Dim DataHeight As Single
Dim NoMoreRecords As Boolean
NoMoreRecords = False

'Debugging variable so I don't have to paw through 
'a zillion properties of CCA in the Watch pane all the time
Dim WhatsMyAnchor As Single
WhatsMyAnchor = CurrentClientAnchor.Row

Do Until NoMoreRecords = True 'Loop captures falling through the last record, internal exit catches
  'the next result each time

  'Surprisingly the main loop. For each client, find the next one or end of job,
  'use that as an upper and lower bound to create and write the invoice

  'Transplanted inline from what should be a sub, because I need it to Just Work Now.
  'As a sub, causes Object Required error on passing the range which is a range into the range slot that's designated as a range.
  'This should become some clever run-once array of nonempty ranges someday

  'Find next nonempty A. If none before lastrow, last record; find last nonempty F, set rows, copy data, terminate macro.
  'If found, set rows and copy data
  DataHeight = 1
  Do Until CurrentClientAnchor.Offset(DataHeight, 0).Value <> ""
    'Find the next nonempty cell below CurrentClientAnchor and record the offset
    'We're falling off the bottom of the last one, have to do our special last search up front here.
    If CurrentClientAnchor.Offset(DataHeight, 0).Row = LastRow Then 'special finder for last record down F to first empty cell
      NoMoreRecords = True
      DataHeight = 1
      Do Until CurrentClientAnchor.Offset(DataHeight, 5).Value = ""
          DataHeight = DataHeight + 1
      Loop
      Exit Do
    End If
    DataHeight = DataHeight + 1
  Loop

  'We now have our DataHeight value for the grunt work.
  'Subtract one from it, to convert to the cell offsets we'll use
  DataHeight = DataHeight - 1

  'Inlined from sub again because I apparently don't know how to pass a variable.
  'MakeInvoiceFile
  Dim SourceBook As Workbook
  Set SourceBook = ThisWorkbook
  Dim InvoiceFileName As String
  InvoiceFileName = InvoiceFolder & _
    CurrentClientAnchor.Value & " " & ServiceYear & " " & ServiceMonth & " Invoice" & ".xls"
  Dim DestBook As Workbook
  Dim Template As Workbook
  Application.Workbooks.Open InvoiceTemplatePath
  Set Template = ActiveWorkbook
  Set DestBook = ActiveWorkbook

  DestBook.SaveAs (InvoiceFileName)

  SourceBook.Activate
  'Close for debugging cleanliness, more elegant keep open behavior later
  'Doesn't work. Maybe not even ugly, anyway cut for dev time.
  'Template.Close

  'More debugging watchable variables
  Dim WhereCopyingRow As Single
  Dim WhereCopyingColumn As Single

  Dim CopyRange As Range
  'Client name into job name
  Set CopyRange = CurrentClientAnchor
  WhereCopyingRow = CopyRange.Row
  WhereCopyingColumn = CopyRange.Column
  CopyRange.Copy
  DestBook.Sheets(1).Cells(3, 4).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  'Service address into job location
  Set CopyRange = CurrentClientAnchor.Offset(0, 3)
  WhereCopyingRow = CopyRange.Row
  WhereCopyingColumn = CopyRange.Column
  CopyRange.Copy
  DestBook.Sheets(1).Cells(4, 4).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  'Billing address into billing address
  Set CopyRange = CurrentClientAnchor.Offset(0, 4)
  WhereCopyingRow = CopyRange.Row
  WhereCopyingColumn = CopyRange.Column
  CopyRange.Copy
  DestBook.Sheets(1).Cells(9, 2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  'Billing Date into Date Billed
  'Currently discarded for progress
  'DestBook.Sheets(1).Cells(24, 3).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  'Descriptions
  Set CopyRange = Range(CurrentClientAnchor.Offset(0, 5), CurrentClientAnchor.Offset(DataHeight, 5))
  WhereCopyingRow = CopyRange.Row
  WhereCopyingColumn = CopyRange.Column
  CopyRange.Copy
  DestBook.Sheets(1).Cells(13, 2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  'Totals
  Set CopyRange = Range(CurrentClientAnchor.Offset(0, 14), CurrentClientAnchor.Offset(DataHeight, 15))
  WhereCopyingRow = CopyRange.Row
  WhereCopyingColumn = CopyRange.Column
  CopyRange.Copy
  DestBook.Sheets(1).Cells(13, 6).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  'Overall total
  Set CopyRange = CurrentClientAnchor.Offset(DataHeight, 16)
  WhereCopyingRow = CopyRange.Row
  WhereCopyingColumn = CopyRange.Column
  CopyRange.Copy
  DestBook.Sheets(1).Cells(24, 6).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
  DestBook.Save
  DestBook.Close

  'SourceBook appears to be activated when we close DestBook, but it's failing to iterate so let's make sure.
  SourceBook.Activate

  'CurrentClientAnchor = CurrentClientAnchor.Offset(DataHeight + 1, 0)
  'WhatsMyAnchor = CurrentClientAnchor.Row

  'Apparently we can't assign a range to its offset, fails to iterate, so
  'we pop out to selection and back to the variable.

  'CurrentClientAnchor.Offset(DataHeight + 1, 0).Select
  'CurrentClientAnchor = Selection
  'WhatsMyAnchor = CurrentClientAnchor.Row

  'Nope. Escalate to activating and assigning.

  'CurrentClientAnchor.Offset(DataHeight + 1, 0).Activate
  'CurrentClientAnchor = ActiveCell
  'WhatsMyAnchor = CurrentClientAnchor.Row

  'That doesn't iterate either, it's really hard for a programming language in
  'Excel to iterate on the most common object in Excel,
  'so let's turn the blasted stupid debugging variable into an absolute cell selector

  Set CurrentClientAnchor = ActiveSheet.Cells(WhatsMyAnchor + DataHeight + 1, 0)
  WhatsMyAnchor = CurrentClientAnchor.Row

  'That throws a 1004 error with or without the Set, "application or object-defined error", thanks.
  'It's just impossible to move a Range down a few cells. Excel VBA can't do that. You can't vary a Range variable.

Loop
MsgBox "All successfully written"


End Sub

Answer 1

对于一个相对较小的问题，这是很多写作，我建议在未来的问题中删除任何非必要的文本;很多人只会看到大量的文字并继续前进。

关于你的问题，我认为一个小小的改变可以完成这项工作：

如果您只是在他们面前添加Set，那么您已注释掉的示例应该有效：

Set CurrentClientAnchor = CurrentClientAnchor.Offset(DataHeight + 1, 0)

正如你所说的那样

Set CurrentClientAnchor = ActiveSheet.Cells(WhatsMyAnchor + DataHeight + 1, 0)

已更改为

Set CurrentClientAnchor = ActiveSheet.Range("A" & WhatsMyAnchor + DataHeight + 1)

也应该有效。

为什么此Excel 2007 VBA程序无法迭代/重新分配Range变量？

1 个答案: