Inserting new row in excel by VBA - excel

I have an excel spreadsheet. In a column of the spreadsheet I have a list of codes (numbers).These codes (numbers) are sorted from highest to lowest values.(some of these codes has been repeated. For example I have three consecutive line with code 1001200).I want to insert new rows between each codes (in case of having repeated codes i just need one new row (for example i Just need one new row for 1001200 not 3 rows) .
I have written the following code but it does not work.
Sub addspace()
Dim space_1(5000), Space_2(5000)
For n = 1 To 5000
Debug.Print space_1(n) = Worksheets("sheet3").Cells(1 + n, 1).Value
Debug.Print Space_2(n) = Worksheets("sheet3").Cells(2 + n, 1).Value
Next
For n = 1 To 5000
If space_1(n) <> Space_2(n) Then
Range("space_1(n)").EntireRow.Insert
End If
Next
End Sub
How can I fix it? (From the code you can see that I am so beginner :)))
Cheers

To insert one empty row between each unique value try this:
Option Explicit
Public Sub addspace()
Dim i As Long
Application.ScreenUpdating = False
With Worksheets("sheet3")
For i = 5000 To 2 Step -1
While .Range("A" & i - 1) = .Range("A" & i)
i = i - 1
Wend
.Rows(i).Insert Shift:=xlDown
Next
End With
Application.ScreenUpdating = True
End Sub
It starts from the end row and moves up, skipping duplicates

The Range("space_1(n)") is invalid. Arg of range object should be a column name like "A1", you can use Range("A" & n).EntireRow.Insert in your code. But I recommend my code.
Please try,
Sub addspace()
Dim n As Integer
For n = 1 To 5000
If Worksheets("sheet3").Cells(n, 1).Value <> Worksheets("sheet3").Cells(n + 1, 1).Value Then
Worksheets("sheet3").Cells(n + 1, 1).EntireRow.Insert
n = n + 1
End If
Next
End Sub

Related

Print and count unique values from an .xlsx file to another column in the excel sheet using VBA

I'm fairly new to Excel VBA and still learning the ropes, so I need help with a step by step program without using any functions. I understand how to count through an unknown column range and output the quantity. However, for this program, I'm trying to loop through a column, picking out unique numbers and counting its frequency.
So I have an excel file with random numbers down column A. I only put in 20 numbers but let's pretend the range is unknown. How would I go about extracting the unique numbers and inputting them into a separate column along with how many times they appeared in the list?
I have a code, but it's not working and I don't know why.
Public Sub CreateInventoryReport()
Dim bcode As Long
Dim ubcode As Long
'Below is the part that is not working
If Worksheets("Sheet 2").Range("A1")<>" Then
' First Value Is unique
Worksheets("Sheet2").Range("D5") = Worksheets("Sheet2").Range("A1")
Worksheets("Sheet2").Range("E5") = 1
Else
r = MsgBox("no data", , "no data")
Exit Sub
End If
bcode = 2
Do While Worksheets("Sheet 2").Cell(bcode, 1) <> ""
ubcode = 5
IsMatch = False
Do While Worksheets("Sheet 2").Cell(ubcode, 4) <> ""
If Worksheets("Sheet 2").Cell(bcode, 1) = Worksheets("Sheets2").Cell(ubcode, 4) Then
Worksheets("Sheet 2").Cell(ubcode, 5) = Worksheets("Sheet2").Cell(ubcode, 5) + 1
IsMatch = True
Exit Do
End If
ubcode = ubcode + 1
Loop
If IsMatch = False Then
Worksheets("Sheet2").Cell(ubcode, 4) = Worksheets("Sheet2").Cell(bcode, 1)
Worksheets("Sheet 2").Cell(ubcode, 5) = 1
End If
bcode = bcode + 1
Loop
End Sub

VBA to auto increment row number into a new column in Excel

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

Sum every odd row in a single Column VBA

I have a code that searches an excel fill for the word distance, takes the value of the cell next to it, paste it into a new cell, then sums all the cells up. Which works great, but i now need to find a way to only sum ever even row number. Does that make sense?
Sub Distance_Check()
Dim DistanceCheck As String
Dim DistanceNumber As String
Dim DistanceSum As String
Dim DistanceTotal As String
DistanceCheck = MsgBox("Would you like to check the distance?", vbYesNo)
If DistanceCheck = vbYes Then
If IsArray(fname) Then Workbooks.OpenText fname(1)
i = 1
findStr = "Distance"
Set foundCel = Range("A:A").Find(what:=findStr)
If Not foundCel Is Nothing Then
firstAddress = foundCel.Address
Do
Range("J" & i).Value = foundCel.Offset(0, 1).Value
Set foundCel = Range("A:A").FindNext(foundCel)
i = i + 1
Loop While Not foundCel Is Nothing And foundCel.Address <> firstAddress
End If
Set wkbSourceBook = ActiveWorkbook
DistanceNumber = i - 2
DistanceSum = WorksheetFunction.Sum(Range(Cells(2, 15), (Cells(DistanceNumber + 1, 15))))
DistanceTotal = DistanceSum / DistanceNumber
If DistanceNumber = Cells(2, 12) Then
MsgBox ("No error found wihin distance")
Else
MsgBox ("Error found with distance")
End If
Else
End If
Call Save_Data
End Sub
Would the way youd go about this be using a for loop on the
cells(DistanceNumber(j,+1)
Where j = 0,
j = j +2 ,
Until j > DistanceNumber,
Would that work? If so how would you go about it?
Thanks
A quick way to step through a loop in the desired increments is to use the Mod operator which divides two numbers and returns any remainder (e.g. 7 mod 2 = 1, as two sixes fit into seven, leaving one).
You can use the row property of the range you identify with the Find method, and since you want to jump by two the modulo should be zero:
If foundcel.Row Mod 2 = 0 Then Range("J" & i).value = foundcel.Offset(0, 1).Value
That said, there is a 'built in' way to step through a loop if using a For loop like this
For x = 2 to 10 Step 2
' Do stuff
Next x
You can also use this method to step backwards, e.g.
For x = 100 to 0 Step -10
' Do stuff backwards!
Next x

Logic issue at the end of a loop

I have a spreadsheet with a column filled with strings. There are sometimes several instances of one string (I've sorted it though so they're all grouped together) so I've created a macro that looks at the current row in the column, determines if its already been posted in the second worksheet, and if it has, it moves to the next row, if it hasn't it posts it and then moves on.
It works perfectly until the end where it completely ignores the last entry. The last entry is one of the instances where there's several of the same strings so the issue almost definitely isn't that its just ignoring the last row.
It's ignoring the last entry completely no matter how many times it repeats. New to vba so any help appreciated.
Sub RCFS()
Dim ProfCtr As String
Dim S2FreecellH As Long
Dim ProfCenCellH As Long
S2FreecellH = 3
ProfCenCellH = 2
ProfCtr = Cells(ProfCenCellH, 4)
Worksheets("Sheet2").Cells(S2FreecellH, 1).Value = ProfCtr
While IsEmpty(Cells(ProfCenCellH, 4).Value) = False
If Cells(ProfCenCellH, 4).Value <> ProfCtr Then
Worksheets("Sheet2").Cells(S2FreecellH, 1) = ProfCtr
S2FreecellH = S2FreecellH + 1
ProfCtr = Cells(ProfCenCellH, 4)
ProfCenCellH = ProfCenCellH + 1
Else
ProfCenCellH = ProfCenCellH + 1
End If
Wend
End Sub
Indeed, your loop needs to still flush the value of ProfCtr even when you reached the empty cell. You can make it work by looking ahead one row in your If condition (add + 1).
Also included a couple of other improvements:
Do While Not IsEmpty(Cells(ProfCenCellH, 4).Value)
If Cells(ProfCenCellH + 1, 4).Value <> ProfCtr Then
Worksheets("Sheet2").Cells(S2FreecellH, 1) = ProfCtr
S2FreecellH = S2FreecellH + 1
ProfCtr = Cells(ProfCenCellH, 4)
End If
ProfCenCellH = ProfCenCellH + 1
Loop
Let me see if I have this right
' Stop when you reach an empty cell
While IsEmpty(Cells(ProfCenCellH, 4).Value) = False
' If the cell's value matches the variable ProfCtr then
' ignore it and move to the next row.
If Cells(ProfCenCellH, 4).Value <> ProfCtr Then
' But if it -doesn't- match, then copy the variable
' ProfCtr to Sheet 2.
Worksheets("Sheet2").Cells(S2FreecellH, 1) = ProfCtr
' Increment your rows
S2FreecellH = S2FreecellH + 1
' Set the next bit of text to copy
ProfCtr = Cells(ProfCenCellH, 4)
ProfCenCellH = ProfCenCellH + 1
Else
ProfCenCellH = ProfCenCellH + 1
End If
Shouldn't you be setting Prof Ctr = Cells(ProfCenCelH, 4) BEFORE doing the copying over to Sheet2?
trincot has the correct answer. Here is an alternate technique, using built-in method, that will accomplish the same task.
With Worksheets("Sheet1")
.Range("D1", .Range("D" & .Rows.Count)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range("A1"), Unique:=True
End With

Excel macro to loop through range until value found, populate range below found cell with formula

I have a large table, sometimes with hundreds of rows.
This table is generated by another application that exports to excel.
One column has the heading "Adjusted Price".
I want all the rows in this column to contain a formula (presently they're all 0's).
I want to automate this process because the table gets regenerated all the time.
This column may not always be in the same place. So I need a macro that can find this column ("Adjusted Price") and then fill all the cells in that column with a formula (with the exception of the first row of course).
Can this be done?
Thanks in advance :)
Your homework is to figure out how to plug it in!
Option Explicit
Sub setAdjustedPrice()
Dim column As Integer
Dim adjustedPriceColumn As String
Dim found As Boolean
Dim rowCount As Long
column = 1
rowCount = 1
Do While Range(FncAlphaCon(column) & rowCount).Value <> "" And found = False
If (Range(FncAlphaCon(column) & rowCount).Value = "Adjusted Price") Then
found = True
adjustedPriceColumn = FncAlphaCon(column)
Else
column = column + 1
End If
Loop
If found = True Then
Do While rowCount < ActiveSheet.UsedRange.Rows.count
rowCount = rowCount + 1
Range(adjustedPriceColumn & rowCount) = "YOUR FORMULA"
Loop
Else
MsgBox ("'Adjusted Price' column not found, cannot continue.")
End If
End Sub
Private Function FncAlphaCon(aNumber As Integer) As String
' Fixed version 27/10/2011
Dim letterArray As String
Dim iterations As Integer
letterArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If aNumber <= 26 Then
FncAlphaCon = (Mid$(letterArray, aNumber, 1))
Else
If aNumber Mod 26 = 0 Then
iterations = Int(aNumber / 26)
FncAlphaCon = (Mid$(letterArray, iterations - 1, 1)) & (Mid$(letterArray, 26, 1))
Else
'we deliberately round down using 'Int' as anything with decimal places is not a full iteration.
iterations = Int(aNumber / 26)
FncAlphaCon = (Mid$(letterArray, iterations, 1)) & (Mid$(letterArray, (aNumber - (26 * iterations)), 1))
End If
End If
End Function

Resources