Firstly the Data.
A B
Type 15 5
Type 2 7
Type 3 9
I need to create a loop, that starts at B1 and inserts a number of rows based on the cell value of B.
I found the below code , but it does not loop, and i need the next cell it checks to be the result of the first cell(5) + 1 in order for it to be correct.
**
Result should be :
**
A B
Type 1 5
Type 2 7
Type 3 9
etc.
Thanks in advance !
I messed up the question in the first place, however i have found the answer.
Please see below.
Sub InsertRowsIf()
Dim lr As Long, R As Range, i As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
Set R = Range("B1", "B" & lr)
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
If IsNumeric(R.Cells(i, 1).Value) And Not IsEmpty(R.Cells(i, 1)) Then
R.Cells(i, 1).Offset(1, 0).Resize(R.Cells(i, 1).Value).EntireRow.Insert
End If
Next i
Application.ScreenUpdating = True
End Sub
Related
I currently have an Excel spreadsheet where column B has a value that I want to identify as a group and then write that group number in column C. Column B is presorted A-Z. Here's a sample where column A is the record number, column B is text info to sort through, and column C is the sequential group created and written by this formula or sub. There are about 100,000 rows to iterate through.
A
B
C
6
ARNOLD
1
7
ARNOLD
1
8
ARNOLD
1
9
ARNOLD
1
16
DEWY
2
17
DEWY
2
18
DEWY
2
14
FOX
3
15
FOX
3
19
JAMIE
4
20
JAMIE
4
Thanks for your help - Jack
I misread originally and I now see that your data is presorted. So to simply label the entries, the following should work for you:
Range("B:B").Select
Dim curval As Long
curval = 1
Do
On Error Resume Next
Selection.ColumnDifferences(ActiveCell).Select
If Err.Number <> 0 Then
On Error GoTo -1
Exit Do
End If
Range("C" & Selection.Row) = curval
curval = curval + 1
Loop
First, we select the column and create our index variable. Then, we loop through Selection.ColumnDifferences(ActiveCell).Select. This will highlight the full set with the first entry being the selected point. Having that, we can set our column C, which would be the first row to the current index and increase the index for the next set.
Using this feature (Selection.ColumnDifferences(ActiveCell).Select) will raise an error upon completion. So, we preceed that with On Error Resume Next and follow it up by checking for the error. If it exists, we exit the loop and clear the error (On Error Goto -1).
Edit: The following should solve your issue of populating ALL as opposed to just the first entry:
Public Sub test()
Range("B:B").Select
Dim curval As Long, prev_row As Long
curval = 1
prev_row = 2
On Error Resume Next
Set first_sel = Selection.ColumnDifferences(ActiveCell)
first_sel.Select
Do
Set second_sel = Selection.ColumnDifferences(ActiveCell)
second_sel.Select
If Err.Number <> 0 Then
On Error GoTo -1
Exit Do
End If
Range("C" & first_sel.Row & ":" & "C" & second_sel.Row - 1) = curval
Set first_sel = second_sel
curval = curval + 1
Loop
End Sub
I currently have a sheet with values that look like this, as an example:
1 A B C D..............
2 1 Title of item 1
3 Formulas and formatting 1
4 2 Title of item 2
5 Formulas and formatting 2
6 3 Title of item 3
7 Formulas and formatting 3
What i want to happen is that the code looks up column A. If column A contains a number > 1 then it inserts that number (-1) rows, but 2 rows down. I then need it fill the formulas (the formulas need to be dragged down) and formats down from the row above to the last row inserted for that section. So it would look something like this:
1 A B C D...............
2 1 Title of item 1
3 Formulas and formatting 1
4 2 Title of item 2
5 Formulas and formatting 2
6 Formulas and formatting 2
7 3 Title of item 3
8 Formulas and formatting 3
9 Formulas and formatting 3
10 Formulas and formatting 3
And so on and so.... Note, it needs to drag the entire row formulas and foramts, not just A-D...
I think I am almost there with the following code, but I can't get it to fill down from the first row with formulas, under the value in A, until the last row inserted for that section....
Here's my code:
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(r, "A").Value > 1 Then Rows(r + 2).Resize(Cells(r, "A").Value - 1).Insert
Next r
Application.ScreenUpdating = True
End Sub
If any one could help me with the above that would be amazing!! Equally, I think my method might be a bit clumsy, so I am open to more eloquent solutions too!! Thanks Guys, this forum has saved my skin so many times!!! One day I hope I will get to a point where I can maybe answer some questions instead of always asking them!
Try this. You're not actually copying and pasting anything.
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If IsNumeric(Cells(r, "A")) Then
If Cells(r, "A").Value > 1 Then
Rows(r + 2).Resize(Cells(r, "A").Value - 1).Insert shift:=xlDown
Rows(r + 1).Copy
Rows(r + 2).Resize(Cells(r, "A").Value - 1).PasteSpecial xlPasteAll
End If
End If
Next r
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Goto Range("A1")
End Sub
I have two excel sheets, one cumulative (year-to-date) and one periodic (quarterly). I am trying to check for potential entry errors.
Simplified ytd table:
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 6 12 20 28 10 20
2 5 11 18 26 10 20
3 5 11 18 26 10 20
Simplified quarterly table:
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 6 6 8 8 10 10
2 5 6 7 8 10 10
3 5 6 7 8 10 10
In the above example there are no entry errors.
I am trying to create a third sheet that would look something like this
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 T T T T T
2 T T T T T
3 T T T T T
I initially tried using a formula like this:
=IF('YTD'!C2-'YTD LC'!B2-'QTR'!B2=0,T,F)
I don't particularly like this because the formula will not apply in the first quarter. This also assumes that my data in both sheets are ordered in the same way. Whilst I believe it to be true in all cases, I would rather have something like an index-match to confirm.
I tried working on a VBA solution based on other solutions I found here but made less progress than via the formulas:
Sub Compare()
lrow = Cells (Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xltoLeft).Column
Sheets.Add
ActiveSheet.Name = "Temp Sheet"
For i = 2 To lrow
For j = 3 To lcol
valytd = Worksheets("YTD").Cells(i,j).Value
valytd = Worksheets("YTD").Cells(i,j).Value
If valytd = valytd Then
Worksheets("Temp").Cells(i,j).Value = "T"
Else:
Worksheets("Temp").Cells(i,j).Value = "F"
Worksheets("Temp").Cells(i,j).Interior.Color Index = 40
End If
Next j
Next i
End Sub
In my opinion the easiest way is to:
Create a sheet & copy paste row 1 + Column 1 like image below (Title & IDs)
Use Sum Product to get your answers
Formula:
=IF(SUMPRODUCT((Sheet1!$B$1:$G$1=Sheet3!$B$1)*(Sheet1!$A$2:$A$4=Sheet3!A2)*(Sheet1!$B$2:$G$4))=SUMPRODUCT((Sheet2!$B$1:$G$1=Sheet3!$B$1)*(Sheet2!$A$2:$A$4=Sheet3!A2)*(Sheet2!$B$2:$G$4)),"T","F")
Formula Notes:
Keep fix the range with Quarters using double $$ -> Sheet1!$B$1:$G$1
keep fix the range with IDs using double $$ -> Sheet1!$A$2:$A$4
Keep fix the range with values -> Sheet1!$B$2:$G$
Keep fix column header -> =Sheet3!$B$1
Leave variable rows number -> =Sheet3!A2
Images:
This should do the trick, the code is all commented:
Option Explicit
Sub Compare()
Dim arrYTD As Variant, arrQuarterly As Variant, arrResult As Variant
Dim Compare As Scripting.Dictionary 'You need Microsoft Scripting Runtime for this to work
Dim i As Long, j As Integer, x As Integer
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
End With
With ThisWorkbook
arrYTD = .Sheets("Name of YTD sheet").UsedRange.Value 'this will get everything on that sheet
arrQuarterly = .Sheets("Name of Quarterly sheet").UsedRange.Value 'this will get everything on that sheet
End With
ReDim arrResult(1 To UBound(arrYTD), 1 To UBound(arrYTD, 2)) 'resize the final array with the same size of YTD
Set Compare = New Scripting.Dictionary
'Here we fill the dictionary with the ID's position on the arrQuarterly array
For i = 2 To UBound(arrQuarterly) '2 because 1 is headers
If Not Compare.Exists(arrQuarterly(i, 1)) Then 'this is an error handle if you have duplicated ID's
Compare.Add arrQuarterly(i, 1), i 'now we know the position of that ID on the table
Else
'Your handle if there was a duplicated ID
End If
Next i
'Let's fill the headers on the result array
For i = 1 To UBound(arrYTD, 2)
arrResult(1, i) = arrYTD(1, i)
Next i
'Now let's compare both tables assuming the columns are the same on both tables (same position)
For i = 1 To UBound(arrYTD)
arrResult(i, 1) = arrYTD(i, 1) 'This is the ID
For j = 2 To UBound(arrYTD, 2)
x = Compare(arrYTD(i, 1)) 'this way we get the position on the quarterly array for that ID
If arrYTD(i, j) = arrQuarterly(x, j) Then 'compare if they have the same value on both sides
arrResult(i, j) = "T"
Else
arrResult(i, j) = "F"
End If
Next j
Next i
With ThisWorkbook.Sheets("Name of the result sheet") 'paste the array to it's sheet
.Range("A1", .Cells(UBound(arrResult), UBound(arrResult, 2))).Value = arrResult
End With
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
lets say in column A:Row 2, I have a score of 45 and in column B, I have the amount of people that got that score. what i then want to do is on column D, output that score X amount of times. x=repitition.
in the exmaple 5 people got a score of 45 so in column D i want to insert 5 scores of 45. then I see in column A:Row2 3 people got a score of 46 then after the last 45, in column D I want to append 46 3 times.. and so on..
Could someone show me how to do this?
Here you go:
Sub test_scores_repitition()
'run with test scores sheet active
r = 1
dest_r = 1
Do While Not IsEmpty(Range("a" & r))
If IsEmpty(Range("b" & r)) Then Range("b" & r).Value = 0 'if there's no quantity listed for a score, it assumes zero
For i = 1 To Range("b" & r).Value
Range("d" & dest_r).Value = Range("a" & r).Value
dest_r = dest_r + 1
Next i
r = r + 1
Loop
End Sub
Macro answer:
Sub WriteIt()
Dim lrow As Long
Dim WriteRow As Long
Dim EachCount As Long
Dim ReadRow As Long
' find last in list of numbers
lrow = Range("A1").End(xlDown).Row
'start at 2 because of headers
WriteRow = 2
ReadRow = 2
While ReadRow <= lrow
For EachCount = 1 To Cells(ReadRow, 2)
'repeat the number of times in column B
Cells(WriteRow, 4) = Cells(ReadRow, 1)
'the number in column A
WriteRow = WriteRow + 1
Next
ReadRow = ReadRow + 1
'and move to the next row
Wend
'finish when we've written them all
End Sub
it is possible with a formula, just not really recommended as it looks auful, and would be difficult to explain. It uses a Microsoft formula to count the number of unique items in the data above, and once it counts the number it is supposed to write of the number above, it moves to the next number. The formula does not know where to stop, and will put 0 when it runs out of data.
in D2, put =A2
In D3, and copied down, put
=IF(COUNTIF($D$2:D2,OFFSET($A$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1)),0))<OFFSET($B$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1)),0),OFFSET($A$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1)),0),OFFSET($A$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1))+1,0))