Background:
I have a sheet named RM that I am pulling milestone data from to a sheet named Finance via a loop (loop is per sheets("RM")). Once the data is pulled forward, the sheet is supposed to group items in two subtotals:
1) Group the milestone activities
2) Group the everything that was pulled over during the loop
Here is the code:
Dim i As Integer
Dim LR As Long, FR As Long
FR = Sheets("Finance").Cells(Sheets("Finance").Rows.Count, 1).End(xlUp).Row
Sheets("Finance").Cells(FR + 1, 1).Value = "Raw Materials"
Sheets("Finance").Cells(FR + 1, 7).Value = Sheets("RM").Cells(12, 2).Value
For i = 16 To 358 Step 18
LR = Sheets("Finance").Cells(Sheets("Finance").Rows.Count, 1).End(xlUp).Row
If Sheets("RM").Cells(i, 4) > 0 And Sheets("RM").Cells(i, 2) = "Fixed" Then
'Milestone row
Sheets("Finance").Cells(LR + 1, 1).Value = Sheets("RM").Cells(i, 1).Value
Sheets("Finance").Cells(LR + 1, 7).Value = Sheets("RM").Cells(i, 4).Value
Sheets("Finance").Rows(LR + 1).Font.Bold = True
'Number
Sheets("Finance").Range(Sheets("Finance").Cells(LR + 2, 1), Sheets("Finance").Cells(LR + 9, 1)).Value = Sheets("RM").Cells(i, 1).Value
'Removed middle section, which pulls over data from different columns
'Group Milestone subactivities
If Sheets("Finance").Cells(LR, 1).Value = Sheets("Finance").Cells(LR - 2, 1).Value Then
Sheets("Finance").Range(Sheets("Finance").Cells(LR + 2, 1), Sheets("Finance").Cells(LR + 9, 1)).EntireRow.Group
Else
End If
Else
End If
Next i
Sheets("Finance").Rows(FR + 1).Font.Bold = True
If LR - FR > 1 Then
Sheets("Finance").Range(Sheets("Finance").Rows(FR + 2), Sheets("Finance").Rows(LR)).EntireRow.Group
Else
End If
Issue:
The grouping for the milestone events is not coming over appropriately. When the code runs, only some of the milestones get their grouping, though the overarching grouping occurs.
In a list of 10 milestones, 1 and 10 do not have milestone grouping, but 2-9 do group.
I thought I had an issue with the if-statement itself, that If LR-FR>2 then, but in stepping-through, I found something weird.
As I step-through with F8, I realized that the data that I .copy/.pastespecial does not show up until after one or two loops have occurred. The grouping then shows up for the last visually-added data that was pasted. Then subsequent data shows up until the last bit.
Question:
Is there a way to force the paste to display data? Is there anything else that would cause this activity from Excel/VBA?
Any help in resolution would be appreciated.
Two things happened to work-around the issue:
1) I had to add another line so the Milestone groupings did not end on the same line as the Section grouping (in this case, after the loop in the subroutine posted in the question).
Dim LR as Long
LR = Sheets("Finance").Cells(Sheets("Finance").Rows.Count, 7).End(xlUp).Row
Sheets("Finance").Cells(LR + 1, 7).Value = "-"
Sheets("Finance").Rows(LR + 1).Font.Bold = True
2) I pulled all of the grouping out to the end, after the loops.
The code for grouping ends up looking like:
Dim a as Integer
LR = Sheets("Finance").Cells(Sheets("Finance").Rows.Count, 7).End(xlUp).Row
For i = 5 To LR
If Sheets("Finance").Cells(i, 1).Font.Bold = False Then
Sheets("Finance").Rows(i).EntireRow.Group
Else
End If
Next i
'Group between sheets
a = Sheets("Finance").Columns(1).Find(What:="Not Raw Materials", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Row
Sheets("Finance").Range(Sheets("Finance").Rows(4), Sheets("Finance").Rows(a - 1)).EntireRow.Group
In the end, I had to make sure the grouping was from the smallest increments to the largest increments to ensure that I did not lose functionality of the mass-grouping (subtotal) toggles. I would often lose the last milestone's subtotal toggle.
Related
So im trying to create a macro in VBA that finds a header e.g. Product number, then pastes all the product numbers and products (the adjacent column) in another workbook (Bill) in the format,
product number - product
until it reaches two blank cells. The problem is the loop runs one too many times and then pastes all the rows followed by "Error" and the red cell because both cells are blank. I've omitted a lot of lines for conciseness, but if it helps im happy to post the rest of it. Ive tried multiple things but just cant fix it. Any help would be appreciated. Thanks in advance.
Set wsDest = Workbooks("Bill.xlsx").Worksheets("Bill")
Lastrow = wsDest.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Offset(RowOffset:=1).Row
Do Until IsEmpty(Cells(i, j)) And IsEmpty(Cells(i, j + 1))
Set ANextFreeCell = wsDest.Cells(Lastrow, "L")
If IsEmpty(Cells(i + 1, j)) Or IsEmpty(Cells(i + 1, j + 2)) Then
ANextFreeCell = "Error"
ANextFreeCell.Interior.Color = RGB(255, 199, 206)
Else
ANextFreeCell = Cells(i + 1, j) & " - " & Cells(i + 1, j + 2)
End If
i = i + 1
Lastrow = Lastrow + 1
Loop
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
RawData is an excel report drawn from an employee database. (Tried to attach the workbook but didn't see how to do that). RawData contains multiple, unwanted duplicate items for some employees. I'm told this is because of a Cartesian join in the employee database that creates the RawData report. Whether or not that's the case, I have no control over how the RawData report is produced. It is what it is.
I need to clean up the RawData report so that the end product looks like the CorrectedView tab, which I corrected manually. RawData can, at times, be several thousand rows so automating the clean-up would be a huge help.
The structure of RawData is in five groupings of columns: Employee Basic Info (cols A-E), Education (cols F-H), Awards (cols I-L), Certifications (cols M-Q) and Accomplishments (cols R-T). In the CorrectedView, what I did was:
Removed the duplicates for each employee in each of the five column sections
Moved the remaining data for each employee upward so that each employee's info begins on his/her first row
Removed any blank rows created between employees after doing #2 above.
I'm looking for a way to automate the process. I have some code (shown below) that accomplishes #1 for the Basic Info section but that's as far as I can get. Thanks for any help.
Sub DelSame()
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = LastRow To 3 Step -1
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then Rows(i).Range("a1:e1").ClearContents
Next i
End Sub
You pretty much have it... use AND for multiple criteria:
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = LastRow To 3 Step -1
If Cells(i, 1).Value = Cells(i - 1, 1).Value AND Cells(i, 2).Value = Cells(i - 1, 2).Value AND Cells(i, 3).Value = Cells(i - 1, 3).Value Then
Rows(i).Delete
End If
Next i
Edit1:
So, the above suits the first grouping of columns... now for the hard part.
You can use AND sections for ALL columns, so you truly don't get any duplicates between rows (should actually fit the bill, as to not accidentally remove any items).
To get more involved, before you remove any rows, you will want to start storing values to more appropriately work with each grouping of columns, such that you work with rows a to b (untested code).
Dim a as Long, b as Long, i as Long, lr as Long
lr = cells(rows.count,1).end(xlup).row
For i = lr to 3 step -1
If cells(i,1).value = cells(i+1,1).value then
If a = 0 then
a = i + 1
End If
Else
If a > 0 AND b = 0 then
b = i + 1
End If
End If
If b > 0 AND a > 0 Then
'perform narrowed actions on range(cells(a,1),cells(b,1))
a = 0 'resets for next grouping
b = 0 'resets for next grouping
End If
Next i
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.