在Excel宏中調整單元格大小

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

我一直在研究你的宏的最終結果。我的目標是找出一個更好的方法來實現這一結果，而不是整理現有的方法。

您將兩個工作簿命名爲「Room Checksums.xls」和「GetReference.xlsm」。 「xls」是Excel 2003工作簿的擴展。 「xlsm」是包含宏的2003年後工作簿的擴展。也許你正確使用這些擴展，但你應該檢查。

我使用Excel 2003，所以我所有的工作手冊都有「xls」的擴展名。我懷疑你需要改變這一點。

我已經創建了三個工作簿：「Room Checksums.xls」，「GetReference.xls」和「Macros.xls」。 「Room Checksums.xls」和「GetReference.xls」僅包含數據。這些宏位於「Macros.xls」中。當只有特權用戶可以運行這些宏時我才使用這個部分，我不希望普通用戶被這些宏所困擾或者無法訪問這些宏。如果您願意，我的下面的宏可以在「GetReference.xls」內放置不變。

下圖顯示了「Room Checksums.xls」的工作表「Sheet1」。我隱藏了大部分行和列，因爲它們不包含與您的宏相關的任何內容。爲了方便起見，我已將單元格值設置爲其地址，但這些值沒有其他意義。

我跑了你的宏。 「房間Checksums.xls」 的「Sheet 2中」成爲：

注：式欄顯示單元格A1爲=Sheet1!$B$6。也就是說，這不是一個價值鏈接。

「GetReference.xls」的活動工作變成了：

注1：在列C中的零至L是因爲你移動12列我假設有這些列中的其他數據。注2，你希望你的「房間Checksums.xls」的「Sheet2的」

：公式欄顯示電池A8爲='[Room Checksums.xls]Sheet2'!A1

我的微距達到相同的結果，你的，但在一個有點。不同的方式。但是，我需要解釋一些宏特性。他們不是絕對必要的，但我相信他們代表了良好的做法。

你的宏包含了很多我稱之爲幻數的東西。例如：B6，AN99,108和A8。這些值可能對貴公司有意義，但我懷疑他們是當前工作簿的事故。您多次使用值108。如果這個值改變爲109，那麼你必須搜索你的代碼108並用109代替它.108的數字非常不尋常，因爲它不太可能出現在代碼中，原因是其他原因，但其他數字可能不是如此不尋常的替代一項艱鉅的任務。目前你可能知道這個數字的含義。你會記得當你回到12個月內修改這個宏嗎？

我已經定義了108作爲常數：

Const Offset1 As Long = 108 

我寧願一個更好的名字，但我不知道這個數字是什麼。您可以用更有意義的名稱替換所有出現的「Offset1」。或者，你可以添加註釋來解釋它是什麼。如果該值變爲109，則對該聲明進行一項更改可修復該問題。我認爲我的大多數名字應該被更有意義的東西取代。

您認爲「Room Checksums.xls」和「GetReference.xlsm」已打開。如果兩者中的一個未打開，宏將停止在相關的激活語句上。也許較早的宏已經打開這些工作簿，但我添加了代碼來檢查它們是否已打開。

我的宏不會粘貼任何東西。它有三個階段：

• 紮實工作，工作表「Sheet1中」 「房Checksums.xls」 的識別序列中最後一個非空單元格：B6，B114，B222，B330，B438，...。

• 在「Room Checksums.xls」的工作表「工作表2」中創建這些條目（和AN99系列）的鏈接。公式只是以符號「=」開頭的字符串，它們可以像任何其他字符串一樣創建。

• 在「GetReference.xls」的工作表「Xxxxxx」中創建「Room Checksums.xls」的「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