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
Related
I have the below code to insert rows. I find that it is a bit slow. v is the number of rows to add and lRow + 1 is the start position to add from.
For q = 1 To v
ExpectedFeesTbl.ListRows.Add (lRow + 1)
ExpectedFeesTbl.ListRows(lRow).Range.Copy
ExpectedFeesTbl.ListRows(lRow + 1).Range.PasteSpecial Paste:=xlPasteFormats
ExpectedFeesTbl.ListRows(lRow + 1).Range.PasteSpecial Paste:=xlPasteFormulas
Application.CutCopyMode = False
Next q
Thanks
You don't need to add rows in the loop, seeing how you know the amount of rows to add. Adding all v rows outside the loop at once should speed up the code.
'Add rows
ExpectedFeesTbl.Rows(lRow + 1).EntireRow.Resize(v).Insert Shift:=xlDown
'Copy information to new rows
For q = 1 To v
ExpectedFeesTbl.ListRows(lRow).Range.Copy
ExpectedFeesTbl.ListRows(lRow + 1).Range.PasteSpecial Paste:=xlPasteFormats
ExpectedFeesTbl.ListRows(lRow + 1).Range.PasteSpecial Paste:=xlPasteFormulas
lRow = lRow + 1
Next q
Application.CutCopyMode = False
note that I added lRow = lRow + 1 because in your original cost the definition of lRow did not change and therefore each iteration of the loop copied from and pasted to the exact same locations.
Additionally, it may be possible to boil down the copy-pasting to a structure that doesn't require a loop. That depends on your workbook structure though
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
I have existing script that does a major chunk of what I need. The script (from here: https://www.extendoffice.com/documents/excel/4054-excel-duplicate-rows-based-on-cell-value.html) basically inserts and then copies rows of data X number of times, where X is one of the fields in the table. It works well and the referenced page shows examples of the start and end points.
But when I run the script in Excel I go from ~2,000 lines in my table to ~40,000 lines. I need to modify all the duplicated rows (incremental dates) and so I am now attemting to also include new data into the table while the script runs that will allow me to change data in the duplicated rows... for example I can use the duplicate number 1, 2, 3, 4 and some simple formulas to change dates relative to a start point.
I expect that I will need some additional code inserted into the routine that will add data into a nominated column and do the auto incrementing from 1.
Having zero actual VBA skillz, ive no idea how to tackle the second part of my problem with the code I already have. Any help would be totally awesome !!
Sub CopyData()
'Updateby Extendoffice 20160922
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "D")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "D")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
Application.ScreenUpdating = False
End Sub
Try this code below, I used the same sample data on the link you provided. However on this code I created 2 worksheets, one for the raw data to be processed and one for the duplicate output including the increment of dates and duplicate number.
Sub duplicateData()
Dim rSH As Worksheet
Set rSH = ThisWorkbook.Sheets("RAW") 'Your raw data
Dim oSH As Worksheet
Set oSH = ThisWorkbook.Sheets("OUTPUT") 'Output data on another sheet
x = 2
For a = 2 To rSH.Range("A" & Rows.Count).End(xlUp).Row
For b = 1 To rSH.Cells(a, 4).Value '4 is the column of duplicate times
If b = 1 Then
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 5) = 1 'First instance, 5 is the column number of duplicate counter
Else
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 3).Value = CDate(oSH.Cells(x - 1, 3).Value) + 1 '3 is the column number of date to increment
oSH.Cells(x, 5).Value = CInt(oSH.Cells(x - 1, 5).Value) + 1 '5 is the column number of duplicate counter
End If
x = x + 1 'Increment Output row number
Next b
Next a
End Sub
I have an Excel spreadsheet with data in two columns as Time and Temperature. The Time column has values such as follows, where there are some skipped seconds:
2017-10-17 14:18:15
2017-10-17 14:18:17
2017-10-17 14:18:18
2017-10-17 14:18:19
2017-10-17 14:18:21
2017-10-17 14:18:22
Is it possible to have Excel add in those missing times with a corresponding blank row (so then I can do interpolation on those blank spots?)
I am not sure how your data look like but this is what you can do if you don't want to use VBA.
Use this formula from cell B2 and drag down:
=IF(B1="","",IF(N(B1),IF(ROW(A2)-ROW($A$1)-1<SECOND(MAX($A$2:$A$7)-MIN($A$2:$A$7))+1,B1+TIME(0,0,1),""),A2))
What this does is to determine how many seconds between max and min and then use the rows as a reference (you can change this part based on your data structure). Try and see if this works for you or not.
Try this! It assumes your times are in column A, with a header in cell A1
Sub AddRows()
'Finds out what row to go up to
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lRow + 1
'If the difference between the cell below is more than a second, then add a
row above and skip the next i
If Cells(i + 1, 1) - Cells(i, 1) > 0.000011575 Then
Cells(i + 1, 1).Select
Selection.EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
lRow = lRow + 1
Cells(i + 1, 1).Select
Cells(i + 1, 1).Value = Cells(i, 1).Value + 0.000011575
i = i + 1
Else
End If
Next i
End Sub
I am trying to merge the cells in a column (column B) based on a condition in another column (Column C).
In Column C, I have a list that starts at 1 and goes to a maximum of 10. However, it may stop at any number before 10 and restart. For Example:
B C
1
2
3
4
5
6
1
2
3
4
1
2
3
4
5
1
As you can see, at B7 and B11, Column C starts over a 1. When this happens, I would like to merge everything above that restart (from 1 to last number before restart). So for this example, I would like to merge B1:B6, B7:10, and B11:15.
This short loop using the WorksheetFunction object MATCH function to locate 'ones' should suffice.
Dim srw As Long, frw As Variant
With Worksheets("Sheet1")
With Intersect(.Columns(3), .UsedRange)
srw = 0
Do While srw < .Rows.Count
frw = Application.Match(1, .Columns(1).Offset(srw + 1, 0), 0)
If Not IsError(frw) Then
.Cells(srw + 1, 1).Resize(frw, 1).Offset(0, -1).Merge
srw = srw + frw
Else
srw = .Cells(Rows.Count, 1).End(xlUp).Row
End If
Loop
End With
End With
It's just a matter of finding the restarting point (the 'ones') and using a little maths to resize the cells to be merged.
an alternative code pattern, using a formula approach with a helper column (cleared before ending) by which jumping through relevant rows only
Option Explicit
Sub test()
Dim i As Long
With Worksheets("Sheet001")
With .Columns(3).SpecialCells(xlCellTypeConstants, xlNumbers)
With .Offset(, 1)
.FormulaR1C1 = "=if(RC[-1]=1,"""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
For i = 1 To .Areas.Count - 1
Range(.Areas(i).Cells(.Areas(i).Count), .Areas(i + 1).Cells(1).Offset(-1)).Offset(0, -2).Merge
Next i
End With
.ClearContents
End With
End With
End With
End Sub