I'm new to VBA and did run into a problem I can't seem to find a solution to on my own -> so Your help is much appreciated :).
I'm getting "Run-time error 9: Subscript out of range" when attempting to run following code:
Dim i as Long, l as Long, x as Long, y as Long, z as Long, lastrow as Long
'..some unrelevant code
x = 2
For y = 1 To lastrow Step 2: For i = y To lastrow Step 2: For z = 0 To 1
'..do stuff
If z = 0 Then
Dim datarange As Variant
Dim myvar As Double
Dim comp As Double
Dim lrow As Long
Dim lcol As Long
l = 0
lrow = x
datarange = Range("k" & x & ":" & "ab" & x + 1).Value
For lcol = 11 To 28
myvar = datarange(lrow, lcol)
comp = datarange(lrow + 1, lcol)
If comp > 1 Then
If myvar > 1 Then
l = l + 1
End If
Else: l = l + 1
End If
Next
End If
x = x + 1
Next: Next: Next
'..etc
I got to this point after implementing the code-part with grey background in effort to include following knowledge into my project: http://blogs.office.com/2008/10/03/what-is-the-fastest-way-to-scan-a-large-range-in-excel/ (third point "Use a variant type variable").
Thanks in advance!
If you'll pardon the expression, you've two-stepped out of the bounds of the array:)
The index numbers of the dataRange array are different then their row/column numbers. If you go to VB Editor, View, and the Locals window as you are stepping through the code (F8), you will see that the array is 1 to 2 by 1 to 18.
Related
I am trying to copy the entry forms I select from the master list to a different worksheet. The idea is that it goes down a condensed list of names without details. Looks at what I have selected. Copies the selected entry form and pastes it in a new place to generate a list that only contains the entry forms I need. I can't tell if the loop is working properly because the paste function at the end isn't working.
Sub BidList()
'Sets unique terms used throught this code
Dim wQuick As Worksheet, wMaster As Worksheet
Dim BlankFound As Boolean
Dim x As Long, n As Long, y As Long
Dim firstrow As Long, pasterow As Long, lastrow As Long, PasteCell As String, MyRange As String
'Turns off Screen updating to save memory
Application.ScreenUpdating = False
'Store an initial value for "x" effectively starting the macro at C4 after the +1 in the next step
x = 3
n = 0
y = 0
Set wQuick = ThisWorkbook.Sheets("Quick Reference")
Set wMaster = ThisWorkbook.Sheets("MASTER")
BlankFound = False
'Loop until x equals 600
Do While BlankFound = False
x = x + 1
n = n + 1
If Trim(wQuick.Cells(x, "B").Value) = "" Then Exit Do
'If there is a 1 in the Boolean column then ...
If Trim(wQuick.Cells(x, "C").Value) = "1" Then
'Move the y value so that the template is pasted in the appropriate place
y = y + 1
'Copy the appropriate form from wMaster
firstrow = (n * 9) + 18
lastrow = (n * 9) + 27
Let MyRange = "A" & firstrow & ":" & "K" & lastrow
wMaster.Range(MyRange).Copy
'Select the next place for the form to be pasted on wQuick
pasterow = (y * 9) - 5
Let PasteCell = "F" & "," & pasterow
wQuick.Cells(PasteCell).Paste
End If
Loop
Application.ScreenUpdating = True
End Sub
Please avoid copy-paste in Excel, better use a for-loop like the following:
# keep track of MyRange.Row and MyRange.Column
For Each cell in wMaster.Range(MyRange):
wQuick.Cells(<Starting point>).Offset(<take the cell coordinates, based on MyRange.Row and/or MyRange.Column>).Value = cell.Value
Next
I have a bubble sort that only works with the first element.
This is solved by reevaluating my array elements and placing them accordingly, which happens if I run the whole thing time and time again.
I'd like to add a recursive loop that's set to break when the sort is done.
I tried adding a function, but I'm not solid enough on my syntax to combine it with my sub. What is a basic recursion loop for this code? Function not expressly required, just something that will let me recall my sub.
Private Sub SortEverything_Click()
Dim everything() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
Dim everyrow As Long
Dim everycol As Long
Dim firstrow As Long
Dim firstcol As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "everything" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim everything(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set everything(y) = check
y = y + 1
check.Select
Next x
'This For has been commented out so that it doesn't run more than once
'For y = 0 To q - 1
'sorting allows us to copy/paste into a helper range line-by-line as the program loops
'firstman is the helper range. firstrow and firstcol return the dimensions of the everything(y) so that we can resize things
Set sorting = everything(0)
Set firstman = .Range("B20")
Set firstman = firstman.Resize(sorting.Rows.count, sorting.Columns.count)
firstman.Value = sorting.Value
firstrow = firstman.Rows.count
firstcol = firstman.Columns.count
'Returns the name of the RM listed to compare to the one below it
sorting.Offset(0, 1).Select
ActiveCell.Select
Temp1 = "" & ActiveCell.Value
For x = 1 To q - 1
'Checks whether a selected component has subcomponents and identifies its dimensions
sorting.Select
Set holder = everything(x)
holder.Offset(0, 1).Select
everyrow = Selection.Rows.count
everycol = Selection.Columns.count
'Returns the name of the material being compared to the referenced material in everything(y)
ActiveCell.Select
Temp2 = "" & ActiveCell.Value
If Temp2 > Temp1 Then 'If the RM we're on comes alphabetically after the name of the one we're checking against, then
If everyrow > 1 Then 'Handles if everything(x) has subcomponents
'Resize the other helper range to be the same as the range with subcomponents and paste the values into it
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(everyrow, everycol)
middleman.Select
middleman.Value = holder.Value
'Resize the range we're pasting into in the master table so it can take the new range, then paste
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
'Resize the holder column to the same size as everything(y).
'Then paste everything(y) into the space BELOW the one we've just shifted upwards
Set holder = holder.Resize(firstrow, firstcol)
Set holder = holder.Offset(everyrow - 1, 0)
holder.Select
holder.Value = firstman.Value
Set sorting = sorting.Offset(everyrow, 0)
Else
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(firstrow, firstcol)
middleman.Select
middleman.Value = holder.Value
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
Set holder = holder.Resize(firstrow, firstcol)
'Set firstman = firstman.Resize(everyrow, everycol)
holder.Select
holder = firstman.Value
Set sorting = sorting.Offset(1, 0)
End If
End If
Next x
'Next y
'This is where my inexperience shows. The recursion should go here, but I'm not sure how to do so.
'PopulateArray (everything)
End With
End Sub
Public Function PopulateArray(myArray()) As Variant
Dim myArray() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "myArray" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim myArray(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set myArray(y) = check
y = y + 1
check.Select
Next x
End With
End Function
Found out what I needed to do. Put the whole thing under a Do loop and then added the following lines to it:
'checking to see if array is completely alphabetized
For Each cell In .Range("B2:B" & lr)
'Returns first check value
If IsEmpty(cell) = False Then
cell.Select
check1 = "" & cell.Value
x = cell.Row
.Range("A14").Value = check1
'Returns next check value
For z = x + 1 To lr
Set checking = .Range("B" & z)
If IsEmpty(checking) = False Then
checking.Select
check2 = "" & .Range("B" & z).Value
.Range("A15").Value = check2
Exit For
End If
Next z
Else
End If
If check2 > check1 Then
Exit For
End If
Next cell
'If the last two values are sorted, then the whole thing is sorted and we can stop the recursion
If check2 < check1 Or check1 = check2 Then
Exit Do
End If
I have a sorted list of names in a single column. I would like to transform the names to 3X8 tables before printing them (printing single column would use too much paper). This is Excel. I'll copy names one by one and paste to a blank sheet.
Using numbers as an example, the resulting order should look like this:
1 9 17
2 10 18
3 11 19
4 12 20
5 13 21
6 14 22
7 15 23
8 16 24
25 33 41
26 34 42
27 35 43
........
Possible to get a general answer (n x m table)?
Below is what I have got. It's close but not quite right.
last_row = ThisWorkbook.Sheets(1).Cells(20000,1).End(xlUp).Row
For i = 1 To last_row/24 +1 Step 1
For k = 1 To 3 Step 1
For j = 1 To members_per_column Step 1
ThisWorkbook.Sheets(1).Cells( i + j + (k - 1) * 8 + (i - 1) * 16 + 1, _
name_column).Copy
Worksheets(destination_page).Cells( i + j - 1, (k - 1) +1).PasteSpecial _
Paste:=xlPasteValues
Next j
Next k
Next i
You were already close. I wrapped the code into a function so you can easily re-use it on any matrix size:
Option Explicit
Public Sub TransformIntoBlocks(ByVal MatrixRows As Long, ByVal MatrixColumns As Long, ByVal SourceRange As Range, ByVal OutputStartRange As Range)
Dim BlockStartRow As Long
BlockStartRow = 1
Dim iRowSource As Long
iRowSource = 1
Dim AmountOfBlocks As Long
AmountOfBlocks = WorksheetFunction.RoundUp(SourceRange.Rows.Count / (MatrixRows * MatrixColumns), 0)
Dim iBlock As Long
For iBlock = 1 To AmountOfBlocks
Dim iCol As Long
For iCol = 1 To MatrixColumns
Dim iRow As Long
For iRow = BlockStartRow To BlockStartRow + MatrixRows - 1
OutputStartRange.Offset(iRow - 1, iCol - 1).Value = SourceRange(iRowSource, 1).Value
iRowSource = iRowSource + 1
Next iRow
Next iCol
BlockStartRow = BlockStartRow + MatrixRows
Next iBlock
End Sub
Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
TransformIntoBlocks MatrixRows:=8, MatrixColumns:=3, SourceRange:=ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)), OutputStartRange:=Tabelle2.Range("C1")
End Sub
Rather than going through three loops, I ended up just using one loop to write in the correct position using mod.
Seems obvious to me as the writer, but please ask questions if it's unclear- it helps the next reader.
Option Explicit
Sub ColumnSplit()
Dim input_rows As Integer
Dim output_columns As Integer
Dim output_rows As Integer
Dim i As Integer
Dim input_sheet As Worksheet
Dim output_sheet As Worksheet
Set input_sheet = Sheet1
Set output_sheet = Sheet2
'output_sheet.Cells.Clear 'optional
output_columns = 3 'Hard coded. Set to whatever you like
input_rows = input_sheet.Cells(Rows.Count, 1).End(xlUp).Row
output_rows = CInt(WorksheetFunction.Ceiling(CDbl(input_rows) / CDbl(output_columns), 1))
For i = 1 To input_rows
output_sheet.Cells( _
((i - 1) Mod output_rows) + 1 _
, (WorksheetFunction.Floor((i - 1) / output_rows, 1) Mod output_columns) + 1 _
) _
= input_sheet.Cells(i, 1) 'cells(calculate output row,calculate output column) = input value
Next i
End Sub
Since i find my problem hard to explain, I'll just provide an example.
This is the format of the data i have in excel in a column, separated by blanks.
A
B
C
D
E
F
G
H
I wish to transpose it so that the final result is:
A B F
C G
D H
E
How do I do that?
Here is Honorez's method:
Sub Honorez()
Dim N As Long, i As Long, j As Long, k As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
k = 0
For i = 1 To N
v = Cells(i, 1)
If v = "" Then
j = j + 1
k = 0
Else
k = k + 1
Cells(k, j) = v
End If
Next i
End Sub
Array method
In addition to #Gary's-Student 's fine solution, I demonstrate another approach using a datafield Array and write back values directly to the new columns:
Sub Honorez2()
Dim rng As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Honorez")
Dim i As Long, ii As Long, j As Long, m As Long, n As Long
Dim a()
' get data
n = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A1:A" & n)
rng.Offset(0, 1).Resize(n, n - WorksheetFunction.CountA(Range("A:A")) + 1) = "" ' clear prior values
' write data field to array
a = rng
j = 2 ' start column for results
For i = 1 To n
If a(i, 1) = "" Or i = n Then
' write data to new column
ws.Range(ws.Cells(1, j), ws.Cells(i - ii, j)).Value = _
ws.Range(ws.Cells(ii + 1, 1), ws.Cells(i, 1)).Value
' remember row and increment column counter
ii = i: j = j + 1
End If
Next i
End Sub
Code was working fine up until a couple of days ago but now getting the subject-line error. Help?
Sub CopyRows()
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("Pacer").Range("L" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
For Each c In Sheets("Pacer").Range("A1:L" & bottomL)
If (c.Value = "AFSB" Or c.Value = "TEIGIP4T" Or c.Value = "EPP") Then
Intersect(c.Parent.Columns("A:Q"), c.EntireRow).Copy Worksheets("Portfolio").Range("A" & x + 1)
x = x + 1
End If
Next c
End Sub
Variable
bottomL As Integer
Will give overflow error the moment it exceeds 32,767 rows. Try declaring it as long
bottomL As Long
Edit: The rule applies to X as well as it is incrementing.
Try this
Option Explicit
Sub CopyRows()
Dim bottomL As Long
Dim x As Long
bottomL = Sheets("Pacer").Range("L" & Rows.CountLarge).End(xlUp).Row: x = 1
Dim c As Range
For Each c In Sheets("Pacer").Range("A1:L" & bottomL)
If (c.Value = "AFSB" Or c.Value = "TEIGIP4T" Or c.Value = "EPP") Then
Intersect(c.Parent.Columns("A:Q"), c.EntireRow).Copy Worksheets("Portfolio").Range("A" & x + 1)
x = x + 1
End If
Next c
End Sub
Reason explained here