在Excelmacros中调整单元格大小

我试图链接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 

问题在于它正在复制和粘贴每个单元格，在这个过程中在表单之间翻转。 我想要做的是select一些分散的单元格，偏移108个单元格，然后select下一个分散单元格的数目（重新resize）。

最好的办法是什么？

Answer 1

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

您将两个工作簿命名为“Room Checksums.xls”和“GetReference.xlsm”。 “xls”是Excel 2003工作簿的扩展。 “xlsm”是包含macros的2003年后工作簿的扩展。 也许你正在使用这些扩展，但你应该检查。

我使用Excel 2003，所以我所有的工作簿都有“xls”的扩展名。 我怀疑你将需要改变这一点。

我创build了三个工作簿：“Room Checksums.xls”，“GetReference.xls”和“Macros.xls”。 “Room Checksums.xls”和“GetReference.xls”只包含数据。 macros是在“Macros.xls”中。 我只使用特权用户可以运行macros，我不希望普通用户对这些macros感到困扰或有权访问这个macros。 如果您愿意的话，我的下面的macros可以放在“GetReference.xls”内而不会改变。

下图显示了“Room Checksums.xls”的工作表“Sheet1”。 我隐藏了大部分行和列，因为它们不包含任何与您的macros相关的内容。 为了方便起见，我已经将单元格值设置为其地址，但这些值没有其他意义。

我跑你的macros。 “Room Checksums.xls”的“Sheet2”成为：

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

“GetReference.xls”的活动工作表变为：

注1：列C到L中的零是因为你移动了12列。 我假设你的“房间Checksums.xls”的“Sheet2”这些列中有其他的数据。

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

我的macros与您的macros达成了相同的结果，但方式稍有不同。 但是，我需要解释一些macrosfunction。 他们不是绝对必要的，但我相信他们是好的做法。

你的macros包含了很多我称之为幻数的东西。 例如：B6，AN99,108和A8。 这些值可能对您的公司有意义，但我怀疑他们是当前工作簿的事故。 您多次使用值108。 如果这个值改为109，那么你将不得不search你的代码108，并用109代替它。这个数字108是非常不寻常的，因为它不太可能出现在你的代码中，因为其他的原因，但是其他的数字可能不是如此不寻常的替代一项艰巨的任务。 目前你可能知道这个数字是什么意思。 你会记得当你回到12个月内修改这个macros吗？

我把108定义为一个常量：

  Const Offset1 As Long = 108 

我宁愿有一个更好的名字，但我不知道这个号码是什么。 你可以用一个更有意义的名字replace所有出现的“Offset1”。 或者，您可以添加注释来解释它是什么。 如果该值变为109，则对该声明进行一次修改就可以解决问题。 我认为我的大部分名字应该被更有意义的东西取代。

您假定“Room Checksums.xls”和“GetReference.xlsm”已打开。 如果两者中的一个未打开，macros将停在相关的激活语句上。 也许较早的macros已经打开这些工作簿，但我已经添加了代码来检查它们是否打开。

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

• 处理“Room Checksums.xls”的工作表Sheet1以识别序列中的最后一个非空单元：B6，B114，B222，B330，B438，…。

• 在“Room Checksums.xls”的工作表“Sheet2”中创build这些条目的链接（和AN99系列）。 公式只是以符号“=”开始的string，可以像其他任何string一样创build。

• 在“GetReference.xls”的工作表“Xxxxxx”中创build“Room Checksums.xls”的“Sheet2”表格中的链接，我不喜欢依赖正确的工作表处于活动状态，您将不得不用“Xxxxxx”正确的价值。

在我的macros中，我试图解释我在做什么，但是我并没有多说关于我正在使用的语句的语法。 你应该没有什么困难find解释的语法，但如果有必要询问。

我想你会发现我的一些言论混乱。 例如：

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

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

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

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

即使没有arrays，这个macros对于新手来说也比我在开始编码时所期望的更难理解。 它分为三个单独的阶段，每个阶段都有一个单独的目的，应该有所帮助。 如果你研究它，我希望你能明白为什么如果工作簿的格式改变，维护起来会更容易。 如果你有大量的数据，这个macros比你的要快得多。

 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