Question

我正在尝试链接Excel工作表中的数据，将它们复制到另一个工作表，然后复制到另一个工作簿。数据是非连续的，我需要的迭代量是未知的。

我现在拥有的部分代码如下：

Sub GetCells()
    Dim i As Integer, x As Integer, c As Integer
    Dim test As Boolean
    x = 0
    i = 0

test = False
Do Until test = True
Windows("Room Checksums.xls").Activate

'This block gets the room name
Sheets("Sheet1").Activate
Range("B6").Select
ActiveCell.Offset(i, 0).Select
Selection.Copy
Sheets("Sheet2").Activate
Range("A1").Activate
ActiveCell.Offset(x, 0).Select
ActiveSheet.Paste Link:=True

'This block gets the area
Sheets("Sheet1").Activate
Range("AN99").Select
ActiveCell.Offset(i, 0).Select
Selection.Copy
Sheets("Sheet2").Activate
Range("B1").Activate
ActiveCell.Offset(x, 0).Select
ActiveSheet.Paste Link:=True

i = i + 108
x = x + 1
Sheets("Sheet1").Activate
Range("B6").Activate
ActiveCell.Offset(i, 0).Select
test = ActiveCell.Value = ""
Loop

Sheets("Sheet2").Activate
ActiveSheet.Range(Cells(1, 1), Cells(x, 12)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("GetReference.xlsm").Activate
Range("A8").Select
ActiveSheet.Paste Link:=True

End Sub

问题是它正在逐个复制和粘贴每个单元格，在此过程中在工作表之间翻转。我想做的是选择一些散布的单元格，偏移108个单元格，然后选择下一个分散的单元格数量（重新调整大小）。

最好的方法是什么？

Answer 1

我一直在研究你的宏的最终结果。我的目标是确定一种更好的方法来实现这一结果，而不是整理现有的方法。

您为两个工作簿命名：＆＃34; Room Checksums.xls＆＃34;和＆＃34; GetReference.xlsm＆＃34;。＆＃34; XLS＆＃34;是Excel 2003工作簿的扩展。＆＃34; XLSM＆＃34;是包含宏的2003年后工作簿的扩展。也许你正确使用这些扩展，但你应该检查。

我使用Excel 2003，所以我的所有工作簿都扩展了＆＃34; xls＆＃34;。我怀疑你需要改变它。

我创建了三个工作簿：＆＃34; Room Checksums.xls＆＃34;，＆＃34; GetReference.xls＆＃34;和＆＃34; Macros.xls＆＃34;。＆＃34; Room Checksums.xls＆＃34;和＆＃34; GetReference.xls＆＃34;只包含数据。这些宏在＆＃34; Macros.xls＆＃34;中。当只有特权用户可以运行宏时，我才使用这种划分，我不希望普通用户被这些宏所困扰或有权访问这些宏。我的下面的宏可以放置在＆＃34; GetReference.xls＆＃34;如果你愿意的话。

下图显示＆＃34; Room Checksums.xls＆＃34;的工作表“Sheet1”。我隐藏了大部分行和列，因为它们与宏没有任何关系。为方便起见，我已将单元格值设置为其地址，但这些值没有其他意义。

“Sheet1” of "Room Checksums.xls"

我跑了你的宏。＆＃34; Room Checksums.xls＆＃34;“Sheet2”成为：

“Sheet2” of "Room Checksums.xls"

注意：公式栏将单元格A1显示为=Sheet1!$B$6。也就是说，这是一个链接，而不是一个值。

＆＃34; GetReference.xls的活动工作表“成为：

active worksheet of "GetReference.xls”

注1：C到L列中的零是因为您移动了12列。我假设您的＆＃34; Room Checksums.xls＆＃34;的“Sheet2”的这些列中还有其他数据。你想要的。

注2：公式栏将单元格A8显示为='[Room Checksums.xls]Sheet2'!A1。

我的宏取得与您相同的结果，但方式略有不同。但是，我的宏需要解释一些功能。它们并非绝对必要，但我相信它们代表着良好的实践。

你的宏包含很多我称之为幻数的内容。例如：B6，AN99,108和A8。这些值可能对贵公司有意义，但我怀疑它们是当前工作簿的意外。您多次使用值108。如果此值更改为109，则必须搜索代码108并将其替换为109.数字108非常不寻常，因为其他原因不太可能出现在代码中，但其他数字可能不是如此不同寻常的替换是一项艰巨的任务。目前你可能知道这个数字意味着什么。你会记得12个月后你回来修改这个宏吗？

我已将108定义为常量：

  Const Offset1 As Long = 108

我更喜欢更好的名字，但我不知道这个号码是什么。您可以使用更有意义的名称替换所有出现的“Offset1”。或者，您可以添加注释来解释它是什么。如果值为109，则对此语句进行一次更改可以解决问题。我认为我的大多数名字应该被更有意义的东西取代。

你假设＆＃34;房间Checksums.xls＆＃34;和＆＃34; GetReference.xlsm＆＃34;是开放的。如果它们中的一个未打开，则宏将停止在相关的激活语句上。也许早期的宏已经打开了这些工作簿，但我添加了代码来检查它们是否已打开。

我的宏不粘贴任何东西。它有三个阶段：

解决＆＃34; Room Checksums.xls＆＃34;的工作表“Sheet1”识别序列中的最后一个非空单元格：B6，B114，B222，B330，B438，....
在＆＃34; Room Checksums.xls＆＃34;的工作表“Sheet2”中创建指向这些条目（和AN99系列）的链接。公式只是以符号“=”开头的字符串，它们可以像任何其他字符串一样创建。
将＆＃34; GetReference.xls“的工作表”Xxxxxx“中的链接创建到＆＃34; Room Checksums.xls＆＃34;的”Sheet2“中的表格中。我不喜欢依赖正确的工作表。您必须使用正确的值替换“Xxxxxx”。

在我的宏中，我试图解释我在做什么，但我没有多说我正在使用的语句的语法。您应该很难找到语法的解释，但如果有必要，请确认。

我想你会发现我的一些陈述令人困惑。例如：

    .Cells(RowSrc2Crnt, Col1Src2).Value = "=" & WshtSrc1Name & "!$" & Col1Src1 & _
                                          "$" & Row1Src1Start + OffsetCrnt

没有一个名字像我想的那样有意义，因为我不理解工作表，列和偏移的目的。我没有复制和粘贴，而是构建了一个公式，例如“= Sheet1！$ B $ 6”。如果您使用表达式，则应该能够将每个术语与公式的元素相关联：

"="                              =
WshtSrc1Name                     Sheet1
"!$"                             !$
Col1Src1                         B
"$"                              $
Row1Src1Start + OffsetCrnt       6

这个宏并不像我自己编写的那样，因为我更喜欢使用数组而不是直接访问工作表。我决定在没有添加数组的情况下引入足够多的概念。

即使没有数组，这个宏对新手来说也比我开始编码时的预期更难理解。它分为三个独立的阶段，每个阶段都有一个单独的目的，这应该有所帮助。如果你研究它，我希望你能看到为什么如果工作簿的格式发生变化会更容易维护。如果你有大量数据，这个宏将比你的快得多。

Option Explicit

   Const ColDestStart As Long = 1

   Const Col1Src1 As String = "B"
   Const Col2Src1 As String = "AN"

   Const Col1Src2 As String = "A"
   Const Col2Src2 As String = "B"
   Const ColSrc2Start As Long = 1
   Const ColSrc2End As Long = 12

   Const Offset1 As Long = 108

   Const RowDestStart As Long = 8
   Const Row1Src1Start As Long = 6
   Const Row2Src1Start As Long = 99

   Const RowSrc2Start As Long = 1

   Const WbookDestName As String = "GetReference.xls"
   Const WbookSrcName As String = "Room Checksums.xls"

   Const WshtDestName As String = "Xxxxxx"
   Const WshtSrc1Name As String = "Sheet1"
   Const WshtSrc2Name As String = "Sheet2"

Sub GetCellsRevised()

   Dim ColDestCrnt As Long
   Dim ColSrc2Crnt As Long
   Dim InxEntryCrnt As Long
   Dim InxEntryMax As Long
   Dim InxWbookCrnt As Long
   Dim OffsetCrnt As Long
   Dim OffsetMax As Long
   Dim RowDestCrnt As Long
   Dim RowSrc2Crnt As Long
   Dim WbookDest As Workbook
   Dim WbookSrc As Workbook

   ' Check the source and destination workbooks are open and create references to them.

   Set WbookDest = Nothing
   Set WbookSrc = Nothing

   For InxWbookCrnt = 1 To Workbooks.Count
     If Workbooks(InxWbookCrnt).Name = WbookDestName Then
       Set WbookDest = Workbooks(InxWbookCrnt)
     ElseIf Workbooks(InxWbookCrnt).Name = WbookSrcName Then
       Set WbookSrc = Workbooks(InxWbookCrnt)
    End If
   Next

   If WbookDest Is Nothing Then
     Call MsgBox("I need workbook """ & WbookDestName & """ to be open", vbOKOnly)
     Exit Sub
   End If

   If WbookSrc Is Nothing Then
     Call MsgBox("I need workbook """ & WbookSrcName & """ to be open", vbOKOnly)
     Exit Sub
   End If

  ' Phase 1.  Locate the last non-empty cell in the sequence: B6, B114, B222, ...
  ' within source worksheet 1

  OffsetCrnt = 0

  With WbookSrc.Worksheets(WshtSrc1Name)
    Do While True
      If .Cells(Row1Src1Start + OffsetCrnt, Col1Src1).Value = "" Then
        Exit Do
      End If
      OffsetCrnt = OffsetCrnt + Offset1
    Loop
  End With

  If OffsetCrnt = 0 Then
     Call MsgBox("There is no data to reference", vbOKOnly)
     Exit Sub
  End If

  OffsetMax = OffsetCrnt - Offset1

  ' Phase 2.  Build table in source worksheet 2

  RowSrc2Crnt = RowSrc2Start

  With WbookSrc.Worksheets(WshtSrc2Name)
    For OffsetCrnt = 0 To OffsetMax Step Offset1
      .Cells(RowSrc2Crnt, Col1Src2).Value = "=" & WshtSrc1Name & "!$" & Col1Src1 & _
                                            "$" & Row1Src1Start + OffsetCrnt
      .Cells(RowSrc2Crnt, Col2Src2).Value = "=" & WshtSrc1Name & "!$" & Col2Src1 & _
                                            "$" & Row2Src1Start + OffsetCrnt
      RowSrc2Crnt = RowSrc2Crnt + 1
    Next
  End With

  ' Phase 3.  Build table in destination worksheet

  RowSrc2Crnt = RowSrc2Start
  RowDestCrnt = RowDestStart

  With WbookDest.Worksheets(WshtDestName)
    For OffsetCrnt = 0 To OffsetMax Step Offset1
      ColDestCrnt = ColDestStart
      For ColSrc2Crnt = ColSrc2Start To ColSrc2End
        .Cells(RowDestCrnt, ColDestCrnt).Value = _
              "='[" & WbookSrcName & "]" & WshtSrc2Name & "'!" & _
              ColNumToCode(ColSrc2Crnt) & RowSrc2Crnt
        ColDestCrnt = ColDestCrnt + 1
      Next
      RowSrc2Crnt = RowSrc2Crnt + 1
      RowDestCrnt = RowDestCrnt + 1
    Next
  End With

End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  Dim Code As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.
  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    Code = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      Code = Chr(65 + PartNum) & Code
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = Code

End Function

在excel宏中调整Cell的大小

1 个答案: