In excel i have two column,one is the url and in second column i have numeric values and i want to insert blank rows based on second column numeric value.Values are just like this
first column Second Column
www.google.com 25
www.weslez.com 10
My reqirment is to insert 25 blank rows below first row and 10 blank rows below second row..thanks.
See code below:
Sub InsertRows()
Dim End_Row As Long, n As Long, Ins As Long
End_Row = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For n = End_Row To 1 Step -1
Ins = Cells(n, "B").Value
If Ins > 0 Then Range("B" & n + 1 & ":B" & n + Ins).EntireRow.Insert
Next n
End Sub
Regards
Xsi
Related
I am struggling with changing counter in my macro. I just started my VBA adventure and spend whole day checking forums and tried many codes, but nothing is working.
I have a code which checks lots of conditions in table. In column F I have listed unique values. In column AE I have the same values, but some of them are duplicated, like in 2 or 3 lines. Now my code checks if value from column F exists in column AE and then checks other conditions like if there is "OB" in column AH and some more conditions. Then it counts how many values it found, but it counts duplicates as well. I need to change it to count only unique values from column AH. So lets say if value X is duplicated in AE2 and AE4 and both of them have "OB" in column AH, then counter shows only 1. Can somebody please explain me how to do it?
So if you look at the example, I have a list of unique values in column F. Column AE contain the same values, but in duplicated lines. 1st part of macro, for example, checks if value in column AE has "OB" in column AH and shows counter in J2. But now it shows 7, because it found 7 lines with values with "OB" in AH, but I need it to show 3, because the values are duplicated. Later macro checks if value has "OB" in column AH and if is different than 0 in column AM. Then it shows 2nd counter in K2. Right now it shows 3, because it found 3 lines with two conditions, but I need it to show 1, because it is the same value.
My code:
Dim lr1 As Long
lr1 = Cells(Rows.count, "F").End(xlUp).Row
Dim lr2 As Long
lr2 = Cells(Rows.count, "AE").End(xlUp).Row
Dim count As Long
Dim counter As Long
Dim x As Long
Dim y As Long
'••••••••••••••••• CHECK IF MATERIAL IS USED IN ACTIVE BOM •••••••••••••••••
'Loop in both ranges
For x = 3 To lr1
For y = 3 To lr2
If range("F" & x) = range("AE" & y) Then
'If material is set to OB
If UCase(range("AH" & y)) = "OB" Then
'And is used in BoM
If range("AO" & y) <> "" Then
'And BoM is not OB
If UCase(range("AP" & y)) <> "OB" Then
'Add to counter
count = count + 1
' range("F" & x).Interior.ColorIndex = 3
End If
End If
End If
End If
Next y
Next x
'Display results in J2
If count > 0 Then
range("J2") = count & " found"
range("J2").Font.Color = vbRed
Else
range("J2") = "None"
range("J2").Font.ColorIndex = 10
End If
'••••••••••••••••• CHECK IF MATERIAL IS ON STOCK •••••••••••••••••
'Loop in both ranges
For x = 3 To lr1
For y = 3 To lr2
If range("F" & x) = range("AE" & y) Then
'If material is set to OB
If UCase(range("AH" & y)) = "OB" Then
'And is on stock
If range("AM" & y) <> "0" Then
'Add to counter
counter = counter + 1
End If
End If
End If
Next y
Next x
'Display results in K2
If counter > 0 Then
range("K2") = counter & " on stock"
range("K2").Font.Color = vbRed
Else
range("K2") = "None"
range("K2").Font.ColorIndex = 10
End If
Here your are. The code first checks if the value in column AE is existing in the list of unique values and if column AH = "OB".
If this unique value has not been added to the unique collection, it will be added and the Unique count is increased, else it is ignored.
Function Condition1()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
Dim uniqueRange As Range: Set uniqueRange = ws.Range("F2:F9")
Dim checkList As Collection
Dim i As Integer
Dim UniqueCounter As Integer
Set checkList = New Collection
For i = 2 To 15
Dim findStr As String
findStr = ws.Cells(i, "AE")
If Not uniqueRange.Find(findStr, LookIn:=xlValues) Is Nothing And ws.Cells(i, "AH") = "OB" Then 'Check if Value exists in master, if not ignore
Dim keyExists As Variant
On Error Resume Next
keyExists = Empty
keyExists = checkList(findStr)
On Error GoTo 0
If IsEmpty(keyExists) Then
UniqueCounter = UniqueCounter + 1
checkList.Add findStr, findStr
End If
End If
Next
Condition1 = UniqueCounter
End Function
I have gone crazy with vba projects around the house and helping my wife upping her reports to the next level. I’m having troubles putting down to VBA what I’m thinking. If anyone has felt my pain please shed some light on the actual script that would help me over this hump. Summary might be comparing cell value for certain text using InStr and if doesn't exist the appending characters to the right end. I can append and run thru one cycle of the loop but get confused with trying to write the logic I'm thinking.
Alittle background on the report: One row equals one reservation. Within that row there is a column labeled “Nights”. This column is filtered for any reservation with more than “1” Night. Example: could be 3 nights, 6 nights, and 10 nights doesn’t matter. I have a macro that sorts these reservations and splits the one reservation into multiple rows totaling the number value in the “Nights” column. Basically, copying and inserting the rows next to each other. While this filtered is still applied (SpecialVisibleCells Only). Now I have another column labeled “ResNumber”. With 3, 6, or 10 rows split out the “ResNumber” column is the same number. I’m tasked with walking down this ‘ResNumber” column and appending a “-1” for the first row. A “-2” for the second reservation “-3” for the third and possibly a forth “-4” Until the last row of the copied for that one reservation group. Then the cycle (loop) starts again on the next group or block of rows. Same procedure.
Dim lnrow As Integer
Dim llrow As String
Dim rownuml As Integer 'row checker
Dim colnuml As String 'column checker
Dim count As Integer
Dim total As String 'Value of reservation's "Nights" column Offset(,17)
Dim startnum As Integer 'Start number for counter
Dim actcell As String 'Activecell
startnum = 1
With sh
llrow = .Cells(.Rows.count, 2).End(xlUp).row
If llrow = "" Then Exit Sub
.Cells(2, 2).Resize(llrow - 1).SpecialCells(xlCellTypeVisible).Select
For lnrow = 2 To llrow
rownuml = ActiveCell.row
colnuml = ActiveCell.Column
total = ActiveCell.offset(, 17).Value
For count = 1 To total
rownuml = ActiveCell.row
colnuml = ActiveCell.Column
actcell = ActiveCell.Value
'Compares row 1 and checks resNumber value for "-1" if none exist it appends.
If InStr(ActiveCell.Value, "-1") = 0 Then
ActiveCell.Value = ActiveCell.Value & "-1"
Else
GoTo nexrow
End If
'Compares row 2 and checks resNumber value of above cell.
If InStr(ActiveCell.offset(-1, 0).Value, "-1") = 0 Then
Resume Next
If InStr(ActiveCell.Value, "-2") = 0 Then
ActiveCell.Value = ActiveCell.Value & "-2"
GoTo nexrow
End If
'to jump out of loop nexrow
'ActiveCell moves one row down.
ActiveCell.offset(1, 0).SpecialCells(xlCellTypeVisible).Select
rownuml = ActiveCell.row 'just checking row number
colnuml = ActiveCell.Column 'just checking column number
'since 1st reservation is already in the DB startnum starts at # 1. The counter
startnum = startnum + count
Next count
Next
End With
Try:
Option Explicit
Sub test()
Dim LastRow As Long, Times As Long, Counter As Long, i As Long, y As Long
Dim strNumber As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
strNumber = .Range("B" & i).Value
Times = Application.WorksheetFunction.CountIf(.Range("B2:B" & LastRow), strNumber)
If Times > 1 Then
Counter = 1
For y = 2 To LastRow
If strNumber = .Range("B" & y).Value Then
.Range("B" & y).Value = strNumber & " - " & Counter
.Range("D" & y).Value = 1
Counter = Counter + 1
End If
Next y
End If
Next i
End With
End Sub
Results:
i have an excel table with +19k lines.
Let's assume table has 2 columns ( Departmant,id).
there are 25 departments that each has unique id.
What formula can i use to get each of them's id correctly.
i tried using if, but i guess it doesnt work with + 25 if's in it..
is there any easy way to do it ?
i'm a beginnner and i'm working on this table for 3 days!.
Taken from MrExcel.com. Untested
Sub FindDistinctValues()
Dim LastRowFrom As Long
Dim LastRowTo As Long
Dim i As Long, j As Long
Dim temp As Integer
Dim found As Boolean
'determines the last row that contains data in column A
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row
'Loop for each entry in column A
For i = 2 To LastRowFrom
'get the next value from column A
temp = Range("A" & i).Value
'Determine the last row with data in column B
LastRowTo = Range("B" & Rows.Count).End(xlUp).Row
'initialize j and found
j = 1
found = False
'Loop through "To List" until a match is found or the list has been searched
Do
'check if the value exists in B column
If temp = Range("B" & j).Value Then
found = True
End If
'increment j
j = j + 1
Loop Until found Or j = LastRowTo + 1
'if the value is not already in column B
If Not found Then
Range("B" & j).Value = temp
End If
Next i
End Sub
Following is part of my program which does the follwoing function
It will look into column K and column L and create tabs according to the combinations. For example if column K has a cell value "Apple" and column L has one cell value "Orange" it will create a tab 1) Apple - Orange
The new tab will have all the rows with this combination
So once complete the running of macro , the whole data will get divided to different tabs according to the K - L combination
My problem is it is giving a run time error when entire column K or entire column L has only one value. For example if entire K column has 10 rows and all column k cells has value Apple it will give error. same goes for column L.
Dim m As Integer
Dim area As Range
Count = Range("K:K").SpecialCells(xlLastCell).Row
ActiveSheet.Range("K2:K" & Count).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Z2"), Unique:=True
Columns(26).RemoveDuplicates Columns:=Array(1)
Count1 = Range("L:L").SpecialCells(xlLastCell).Row
ActiveSheet.Range("L2:L" & Count1).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Y2"), Unique:=True
Columns(25).RemoveDuplicates Columns:=Array(1)
Dim arrayv As String
Dim Text1 As String
Dim arrayv1 As String
last = Range("Z2").End(xlDown).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y2").End(xlDown).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
Columns(26).EntireColumn.Delete
Columns(25).EntireColumn.Delete
Dim i As Long, j As Long
Dim flag As Variant
flag = 1
A = 1
s = 2
For c = 1 To UBound(arrayv1)
For t = 1 To UBound(arrayv)
Sheets.Add().Name = "Sheet" & s
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
With Worksheets("Sheet1")
j = 2
.Rows(1).Copy Destination:=Worksheets("Sheet" & s).Range("A" & 1)
flag = 1
For i = 2 To Count
If .Cells(i, 11).Value = arrayv(t) Then
If .Cells(i, 12).Value = arrayv1(c) Then
Text = .Cells(i, 15).Value
flag = 0
.Rows(i).Copy Destination:=Worksheets("Sheet" & s).Range("A" & j)
j = j + 1
End If
End If
Next i
If flag = 1 Then
Sheets("Sheet" & s).Delete
Else
Text1 = Left(Text, 4)
Error line when column K has only one value
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
Error line when column L has only one value
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
If there is only one value Y2 or Z2 downwards then using the Range,End property with an xlDirection of xlDown is going to reference row 1,048,576. The WorksheetFunction.Transpose method has a limit of 65,536. Anything exceeding this limit will result in,
Run-time error '13':Type mismatch.
Change the direction of the last-row-seek to look up from the bottom with xlUp.
last = Range("Z" & rows.count).End(xlUp).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y" & rows.count).End(xlUp).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
New to this so bear with me.
I want to automatically insert a certain number or rows based on a value in another column. Can this be done?
eg
Container Lifts
B0237 1
B0238 7
B0239 7
A8783 2
So the containers would be split by the number of lifts
One for loop nested in a while loop should do your job. Why we are suing while instead of for because we can not dynamically change the limit of For loop when we add a new row in between existing data. So there you go:
Dim LastRow As Long
Dim RowAddNo As Long
LastRow = Range("A1").End(xlDown).Row
i = 2
While i <= LastRow
RowAddNo = Range("B" & i).Value
For J = 1 To RowAddNo
Rows(i + 1 & ":" & i + 1).Insert shift:=xlUp
LastRow = LastRow + 1
i = i + 1 'increasing the 'i' value to find the address for the next not empty row
Next
i = i + 1 'increasing the 'i' value to find the address for the next not empty row
Wend
PS: Do not try without i = i + 1. it goes in an endless loop :)
This will do it for you:
Sub AddRows()
Dim X As Long
For X = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1 'Work backwards when inserting or deleting rows, so much easier than incrementing numbers
Range("A" & X).Offset(1, 0).Resize(Range("B" & X).Value, 1).EntireRow.Insert 'Insert the number of rows against the target row offset by 1 ie below it
Next
End Sub