Resizing Cell in excel macro - vba

Question

I'm trying to link data from an Excel sheet, copy them to another sheet, and then copy onto another workbook. The data is non-contiguous, and the amount of iterations I need is unknown.
A portion of the code that I have now is below:
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
The problem is that it is copying and pasting each cell one by one, flipping between sheets in the process. What I'd like to do is select a number of scattered cells, offset by 108 cells, and select the next number of scattered cells (re-sizing).
What would be the best way to do so?

Answer 1

I have been studying the end result of your macro. My objective is to identify a better approach to achieving that result rather than tidying your existing approach.
You name your two workbooks: "Room Checksums.xls" and "GetReference.xlsm". "xls" is the extension of an Excel 2003 workbook. "xlsm" is the extension of a post-2003 workbook that contains macros. Perhaps you are using these extensions correctly but you should check.
I use Excel 2003 so all my workbooks have an extension of "xls". I suspect you will need to change this.
I have created three workbooks: "Room Checksums.xls", "GetReference.xls" and "Macros.xls". "Room Checksums.xls" and "GetReference.xls" contain nothing but data. The macros are in "Macros.xls". I use this division when only privileged users can run the macros and I do not wish ordinary users to be bothered by or have access to those macros. My macro below can be placed without changes within "GetReference.xls" if you prefer.
The image below shows worksheet “Sheet1” of "Room Checksums.xls". I have hidden most of the rows and columns because they contain nothing relevant to your macro. I have set the cell values to their addresses for my convenience but there is no other significance to these values.
I ran your macro. “Sheet2” of "Room Checksums.xls" became:
Note: the formula bar shows cell A1 as =Sheet1!$B$6. That is, this is a link not a value.
The active worksheet of "GetReference.xls” became:
Note 1: the zeros in columns C to L are because you move 12 columns. I assume there is other data in these columns of “Sheet2” of your "Room Checksums.xls" that you want.
Note 2: the formula bar shows cell A8 as ='[Room Checksums.xls]Sheet2'!A1.
My macro achieves the same result as yours but in a somewhat different manner. However, there are a number of features to my macro which I need to explain. They are not strictly necessary but I believe they represent good practice.
Your macro contains a lot of what I call magic numbers. For example: B6, AN99, 108 and A8. It is possible that these values are meaningful to your company but I suspect they are accidents of the current workbooks. You use the value 108 several times. If this value were to change to 109, you would have to search your code for 108 and replace it by 109. The number 108 is sufficiently unusual for it to be unlikely that it occurs in your code for other reasons but other numbers may not be so unusual making replacement a painstaking task. At the moment you may know what this number means. Will you remember when you return to amend this macro in 12 months?
I have defined 108 as a constant:
Const Offset1 As Long = 108
I would prefer a better name but I do not know what this number is. You could replace all occurrences of “Offset1” with a more meaningful name. Alternatively, you could add comments explaining what it is. If the value becomes 109, one change to this statement fixes the problem. I think most of my names should be replaced with something more meaningful.
You assume "Room Checksums.xls" and "GetReference.xlsm" are open. If one of both of them were not open, the macro would stop on the relevant activate statement. Perhaps an earlier macro has opened these workbooks but I have added code to check that they are open.
My macro does not paste anything. It has three phases:
Work down worksheet “Sheet1” of "Room Checksums.xls" to identify last non-empty cell in the sequence: B6, B114, B222, B330, B438, ... .
Create links to these entries (and the AN99 series) in worksheet “Sheet2” of "Room Checksums.xls". Formulae are just strings which start with the symbol “=” and they can be created like any other string.
Create links in worksheet “Xxxxxx” of "GetReference.xls” to the table in “Sheet2” of "Room Checksums.xls". I do not like relying on the correct worksheet being active. You will have to replace “Xxxxxx” with the correct value.
In my macro I have attempted to explain what I am doing but I have not said much about the syntax of the statements I am using. You should have little difficulty finding explanations of the syntax but do ask if necessary.
I think you will find some of my statements confusing. For example:
.Cells(RowSrc2Crnt, Col1Src2).Value = "=" & WshtSrc1Name & "!$" & Col1Src1 & _
"$" & Row1Src1Start + OffsetCrnt
None of the names are as meaningful as I would like because I do not understand the purpose of the worksheets, columns and offset. Instead of copying and pasting, I am building a formula such as “=Sheet1!$B$6”. If you work through the expression you should be able to relate each term with an element of the formula:
"=" =
WshtSrc1Name Sheet1
"!$" !$
Col1Src1 B
"$" $
Row1Src1Start + OffsetCrnt 6
This macro is not quite as I would have coded it for myself since I prefer to use arrays rather than access worksheets directly. I decided that I was introducing more than enough concepts without the addition of arrays.
Even without arrays this macro is more difficult for a newbie to understand than I had expected when I started coding it. It is divided into three separate phases each with a separate purpose which should help a little. If you study it, I hope you can see why it would be easier to maintain if the format of the workbooks changed. If you have large volumes of data, this macro would be substantially faster than yours.
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