Copy and Pasting an entire row based off of two conditions
For a school project, I am trying to find all the rows that satisfy both (of two) conditions then paste the entire row at the end of my data set. I am trying to do this with variables as the spreadsheet may change in tests that my professor will perform. I keep getting a "Subscript out of range" error. My reading and assigning to P and T, for loop, if statements, and count functions all work.
numrow = Rows(Rows.Count).End(xlUp).row
numcolumn = Columns(Columns.Count).End(xlUp).Column
P = Range(Cells(3, 1), Cells(numrow, 1)).Value
T = Range(Cells(3, 2), Cells(numrow, 2)).Value
For i = LBound(P, 1) To UBound(P, 1)
If P(i, 1) = 5 And T(i, 1) = 100 Then
countrow = countrow + 1 'check: return is 25
'Range(i, numcolumn).copy Sheets("Sheet1").End(xlUp).Offset(1, 0)
Worksheets("Sheet1").Range(Cells(i, numcolumn)).Value.copy
lastrow = ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count + 1
Range(Cells(lastrow, 1)).PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
'I would also like to change all the cells that were just pasted in the first column to the value of 2.5 here, but I have no idea where to start with that
End If
Next i
As you can see I tried it two ways
1.)
Range(i, numcolumn).copy Sheets("Sheet1").End(xlUp).Offset(1, 0)
(which is commented for now)
2.)
Worksheets("Sheet1").Range(Cells(i, numcolumn)).Value.copy
both get highlighted when I try to debug and have the "subscript out of range" error
Related
I have a large set of data that needs to be broken up based on group type in column 4. The goal of the loop is to insert three blank rows and copy-paste the sheet's header on top of the new group. This should continue until the bottom row row. However, it seems like my lastrow3 isn't updating within the loop to account for the new rows inserted. Is there anything I'm missing in re-designating the last row within this For-Next Loop? Thanks!
Dim lastrow3 As Integer, Dim b As Integer
Range("A1").End(xlDown).Select
lastrow3 = ActiveCell.Row
For b = 2 To lastrow3
If Cells(b, 4) <> Cells(b + 1, 4) Then
Rows(b + 1).Resize(3).EntireRow.Insert
Rows("1").Copy
Rows(b + 3).PasteSpecial xlPasteFormats
Rows(b + 3).PasteSpecial xlPasteValues
lastrow3 = lastrow3 + 3
b = b + 4
End If
Next
UPDATED. #garbb makes the right call in the comments. Your For loop is flawed in that you're setting it to end at a specific integer, however this number could change. Basically, you want the loop to continue until it reaches the cell that was was originally marked, taking into account the inserted rows. This can be accomplished by using a Do-While loop which evaluates the row number of that cell if it's set to a variable. As a variable, it will update as you insert rows which addresses your issue.
I tested this out and it should work. Make sure the b=b+1 is in the proper spot. I can't tell without seeing what you did.
Dim theEndRange As Range
Set theEndRange = Range("A1").End(xlDown)
Dim b As Long
b = 2
'set the looping rule here
'theEndRange will update as rows are inserted.
Do While b <= theEndRange.Row
If Cells(b, 4) <> Cells(b + 1, 4) Then
Rows(b + 1).Resize(3).EntireRow.Insert
Rows("1").Copy
Rows(b + 3).PasteSpecial xlPasteFormats
Rows(b + 3).PasteSpecial xlPasteValues
b = b + 4
Else
'without this your code will loop indefinitely!!
'if this is causing an issue, it may need to place outside if statement
b = b + 1
End If
'or here
'b = b+1
Loop
I'm trying to use this code for showing the overflow to another value in the column I in sheet 20170224-SUAGDB. But I'm getting an Error 1004 about the line If Works....Value Then. Can somebody help me with the error?
Dim i As Long
For i = 2 To Rows.Count
If Worksheets("20170224-SUAGDB").Cells(i, 9).Value <> Worksheets("20170224-SUAGDB").Cells((i + 1), 9).Value Then
Cells(i, 9).Font.Color = vbRed
End If
Next i
Since you haven't .select'ed any specific Range() in your Worksheet, your Rows.Count value is equal to 1048576.
You can check it's value using MsgBox Rows.Count.
So, when your loop goes from 1 to 1048576, in the last iteration when you try to compare .Cells(i, 9).Value with .Cells((i + 1), 9).Value, the second term "explodes" your total number of rows!
Your code looks for the row number 1048577 - which don't exists - so it throws a 1004 error.
One possible solutions is changing :
This: For i = 2 To Rows.Count
To this: For i = 2 To Rows.Count - 1
This solution will loop through all - 1 rows even if they don't contain any data.
Or maybe even:
This: For i = 2 To Rows.Count
To this: For i = 2 To Range("I:I").End(xlDown).Row - 1
This solution get the last non-blank row value of the selected column.
ps. If you don't add - 1 in For i = 2 To Range("I:I").End(xlDown).Row - 1, and your worksheet contains some data at the row number 1048576, your code will throw the same error 1004.
Some of your objects are not fully qualified. For instance, get the last row number in column "I" (9) in `Worksheets("20170224-SUAGDB").
Try the code below:
Dim i As Long
With Worksheets("20170224-SUAGDB")
For i = 2 To .Cells(.Rows.Count, 9).End(xlUp).Row '<-- get last row in column "I" (column 9)
If .Cells(i, 9).Value <> .Cells((i + 1), 9).Value Then
.Cells(i, 9).Font.Color = vbRed
End If
Next i
End With
My code need more than one hours to complete for 3500 rows but I need to work for more than 40000 rows data.
I am looking for alternatives to my code by using dictionary, with improved performance within the context of interest.
Could anyone help me?
Sub StripRow2Node()
'Read the Strip Design table
With Sheets("Design-Moment")
Sheets("Design-Moment").Activate
LastR1 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
DM_arr = .Range(Cells(1, 1), Cells(LastR1, 7)) 'Col 1 to Col 7
DM_count = UBound(DM_arr, 1)
End With
'Read the x and y coordinations and thickness of a node in node design
With Sheets("Design-Shear")
Sheets("Design-Shear").Activate
LastR2 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
DS_arr = .Range(Cells(1, 4), Cells(LastR2, 5)) 'Col 4 to Col 5
SX_arr = .Range(Cells(1, 26), Cells(LastR2, 27))
SY_arr = .Range(Cells(1, 30), Cells(LastR2, 31))
DS_count = UBound(DS_arr, 1)
End With
'** Find correponding reference row in Design-Moment for nodes**
'Match node to striip station and output row index
For i = 5 To DS_count
XStrip = SX_arr(i, 1)
XStation = DS_arr(i, 1)
YStrip = SY_arr(i, 1)
YStation = DS_arr(i, 2)
For j = 5 To DM_count
If DM_arr(j, 1) = XStrip Then 'X-Strip Name is matched
If DM_arr(j, 4) >= XStation And DM_arr(j - 1, 4) < XStation Then
SX_arr(i, 2) = j 'matched row reference for X-strip
End If
End If
If DM_arr(j, 1) = YStrip Then
If DM_arr(j, 5) <= YStation And DM_arr(j - 1, 5) > YStation Then
SY_arr(i, 2) = j
End If
End If
Next j
Next i
'Write the matched strip information to node
For i = 5 To LastR2
With Sheets("Design-Shear")
.Cells(i, 27) = SX_arr(i, 2)
.Cells(i, 31) = SY_arr(i, 2)
End With
Next i
End Sub
I suspect that almost all the time is being used writing back cell-by-cell to the sheet here:
'Write the matched strip information to node
For i = 5 To LastR2
With Sheets("Design-Shear")
.Cells(i, 27) = SX_arr(i, 2)
.Cells(i, 31) = SY_arr(i, 2)
End With
Next i
Writing back to Excel is much slower than reading from Excel.
I would suggest switching off screen updating and calculation, accumulating the results (currently X_arr(i, 2) and SY_arr(i, 2)) in separate arrays and then writing the arrays back to a range in a single operation rather than cell-by-cell
There are several points to improve:
1. Use qualified references to avoid.activate statements
You start off nicely with
With Sheets("Design-Shear")
...
DS_arr = .Range(Cells(1, 4), Cells(LastR2, 5)) 'Col 4 to Col 5
but fail to make the Cells objects refer to the With block. Instead use
With Sheets("Design-Shear")
...
DS_arr = .Range(.Cells(1, 4), .Cells(LastR2, 5)) 'Col 4 to Col 5
Now you do not have to activate the sheet anymore.
From the code I have to assume that there is only one possible match returned in this statement:
SX_arr(i, 2) = j
for all i; otherwise, the second, third...occurrence would overwrite this value of j. If that is indeed the case you can stop looping over j once a match is found:
SX_arr(i, 2) = j 'matched row reference for X-strip
Exit For
Shortcut both If statements if DM_arr(j, 1) can match XStrip or YStrip. If these matches are mutually exclusive, use ElseIf instead of If for the second statement.
Shortcutting the j-loop should improve the runtime noticeably. Of course, if you need the last matching index (instead of the first) then this will not apply.
edit:
For a dictionary solution, see for instance the excellent code from Jeeped here: https://codereview.stackexchange.com/questions/133664/searching-values-of-range-x-in-range-y
I'm experimenting with recursive for the first time. In this problem, I have a huge dataset with many rows, and in each row, there's N number of 4 cell ranges to copy (from column O to column GB). I have the following function written:
Function Recursive(Rng As Range)
If N = 1 Then
Rng.Offset(, -3).Resize(, 670).Copy
Rng.Offset(1, -3).Insert Shift:=xlDown
Rng.Offset(, 6).Resize(, 4).Copy
Rng.PasteSpecial Paste:=xlPasteValues
Else
Rng.Offset(, -2).Resize(, 670).Copy
Rng.Offset(1, -2).Insert Shift:=xlDown 'Repeat these two lines N times'
Rng.Offset(, 7 + 4 * N).Resize(, 3).Copy
Rng.Offset(N, 0).PasteSpecial Paste:=xlPasteValues
Recursive (N - 1)
End If
N = 0
End Function
I know it's pretty rough, and I see some problems already. Basically, if N is equal to 4, then I want the first two lines of the Else instruction to be repeated 4 times, then move on to carry out the next three lines over and over until N is equal to 1. Basically, where there are many ranges going across the dataset, I want to create a new line to put them into, including the cells to the left of Rng. Is it possible to put in a line where I've made my comment, that says "Go back and repeat these two lines N times?"
To elaborate on #MarcB's comment, there are many types of loops. I've chosen to do one main loop which reduces N by 1 until N = 0. Within that loop, if N = 1, then your special N = 1 code runs; otherwise if N = 4, it loops 4 times over that section of code, otherwise it runs your 'else' block of code.
Function Recursive(Rng As Range)
Dim OriginalN as Integer
OriginalN = N
While N <> 0
If N = 1 Then
Rng.Offset(, -3).Resize(, 670).Copy
Rng.Offset(1, -3).Insert Shift:=xlDown
Rng.Offset(, 6).Resize(, 4).Copy
Rng.PasteSpecial Paste:=xlPasteValues
ElseIf N = OriginalN Then
For x = 1 To OriginalN
Rng.Offset(, -2).Resize(, 670).Copy
Rng.Offset(1, -2).Insert Shift:=xlDown 'Repeat these two lines N times'
Next x
Else
Rng.Offset(, 7 + 4 * N).Resize(, 3).Copy
Rng.Offset(N, 0).PasteSpecial Paste:=xlPasteValues
Recursive (N - 1)
End If
N = N - 1
Wend
End Function
You refer to 'going back' and redoing code, but using a GoTo statement is often considered sloppy if there are other methods available, as without proper care GoTo statements can run incorrectly/indefinately, and are somewhat harder to read.
The code I have once worked to add/delete groups of rows (requirements). I needed to modify the code so that if the 1st row of the group met certain criteria (i.e, the requirement was not one we wanted to consider), (1) we would not count it and (2), we would hide the group (current and subsequent 2 rows). This all works fine.
The problem is that now that I incorporated these changes, I get an error in another section of the code and for the life of me I cannot figure out why. I have stepped through this and am extremely frustrated. I am reaching out for help, and am hoping someone can see my error(!)
We calculate the start and finish row numbers within a grouping, and store these calculations in Arrays called "Start" and "Finish." I use the ReDim statement to initialize my arrays, because I thought that could be part of the problem, but no.
Any insight as to why my "subscripts are out of range" would be appreciated. I have traced through the logic, investigated this error, and read about the syntax/usage of VBA arrays. I don't know what else to do. Thanks in advance. Here are the relevant lines:
Sub Button1_Click()
Cells.Select
Selection.ClearOutline
If Cells.EntireRow.Hidden Then Cells.EntireRow.Hidden = False
Dim Start() As Integer
Dim Finish() As Integer
Dim p As Integer, q As Integer
ReDim Start(0, 50)
ReDim Finish(0, 50)
The following is embedded in logic that loops through all the rows in the spreadsheet:
i = 1
For Row = 4 To Cells(1, 6).Value - 1
If Begin Then
If Cells(Row, 3).Interior.ColorIndex = 44 Then
Start(i) = Row + 1
j = Cells(Row, 2).Value
Begin = False
End If
Else
If Cells(Row, 2).Value = j + 1 Or Cells(Row, 2).Interior.ColorIndex = 37 Then
Finish(i) = Row - 1
Begin = True
i = i + 1
Row = Row - 1
End If
End If
Next
The block I changed is as follows (code I added is last block where I attempt to hide rows). It precedes the previous. I am wondering how my change could have affect the above(?!)
If Cells(Row, 5).Value = "Requirement" Then
Range(Cells(Row, 4), Cells(Row, 4)).Interior.ColorIndex = 40
Rows(Row).Font.Bold = True
Rows(Row).Font.Italic = False
Rows(Row).Font.ColorIndex = 1 'Black
If Cells(Row - 3, 4).Value = "" Then 'this is requirement #1
Cells(Row, 4).Value = 1
Else
Cells(Row, 4).Value = Cells(Row - 3, 4).Value + 1
End If
p = Row
q = p + 2
Rows(p & ":" & q).Select
If Cells(p, 19).Value = "4" Then
Selection.EntireRow.Hidden = True
Else
Selection.EntireRow.Hidden = False
End If
Redim Start(0,50) makes the array dimensions 0 to 0, 0 to 50 i.e. a 2d array.
This means that when you call the array you need to provide parameters for both dimensions I.E: Start(0,i) or Finish(0,i). Calling Start(i) will result in the error you mentioned.
The easiest way to get rid of the error is to change your Redim lines to
ReDim Start(50)
ReDim Finish(50)
which is what I assume you meant to do in the first place.
Note: Based upon the format you used, you may have been meaning to do Start(0 to 50) and Finish(0 to 50) initially. The comma in the dimensioning indicates another dimension instead of a separation between lower and upper bounds.