Im trying to create an excel macro to select a range of cells then insert new row every other row then copy and paste each row.
For example.
apples
oranges
mangos
My desired goal is
apples
apples
oranges
oranges
mangos
mangos
I have thousands of rows and a macro would be nice.
This Inserts a new row,every other row.
Sub InsertNewRows()
Dim rng As Range
Dim CountRow As Integer
Dim i As Integer
Set rng = Selection
CountRow = rng.EntireRow.Count
For i = 1 To CountRow
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
Next i
End Sub
How can I duplicate the lines in the range too?
Not inserting rows, this code copies and pastes each value twice. Inserting rows is really time consuming.
Here's a screenshot of before/after running code:
Sub test()
Dim MyData As Variant
Dim LR As Long
Dim i As Long
Dim Initial_Row As Long
LR = Range("A" & Rows.Count).End(xlUp).Row 'last non blank cell in column A
MyData = Range("A1:A" & LR).Value 'all data into array
Initial_Row = 1 'initial row where data starts pasting
For i = 1 To UBound(MyData) Step 1
Range("A" & Initial_Row & ":A" & Initial_Row + 1).Value = MyData(i, 1)
Initial_Row = Initial_Row + 2
Next i
Erase MyData 'delete data
End Sub
I recommend to read the values into an array and duplicate them into another array and finally write that array to the cells. This is much faster than duplicating cells.
Option Explicit
Public Sub DuplicateSelectedRows()
Dim SelRng As Range
Set SelRng = Selection
' read values into array
Dim SelectedValues As Variant
SelectedValues = SelRng.Value
' create output array of double the size
Dim DuplicatedValues As Variant
ReDim DuplicatedValues(1 To UBound(SelectedValues, 1) * 2, 1 To UBound(SelectedValues, 2))
' duplicate values
Dim iRow As Long
For iRow = 1 To UBound(SelectedValues, 1)
DuplicatedValues(iRow * 2 - 1, 1) = SelectedValues(iRow, 1)
DuplicatedValues(iRow * 2, 1) = SelectedValues(iRow, 1)
Next iRow
' output values
SelRng.Cells(1, 1).Resize(RowSize:=UBound(DuplicatedValues)).Value = DuplicatedValues
End Sub
Im not sure exactly how to explain this in a google search so im not sure if anyone else has asked this.
I have a vba function that takes a range and turns it into a string of comma separated values.
It works like a charm.
Now i want it to only output the first 41 entries, switch down a row and output the next 41 entries in the range.
I cant quite wrap my head around it, it feels like a simple loop but i cant quite get there.
I found the csvrange macro online somewhere :)
Function csvRange(myRange As Range)
Dim csvRangeOutput
Dim entry As Variant
For Each entry In myRange
If Not IsEmpty(entry.Value) Then
csvRangeOutput = csvRangeOutput & entry.Value & ","
End If
Next
csvRange = Left(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
Input range would look like this
Desired output would look like this, one string located in column B each group of 41 values separated on a row, offsetting 1 down each time the function hits the next nr 42.
Something like this:
Option Explicit
Public Sub test()
Debug.Print csvRange(Selection, 41)
End Sub
Public Function csvRange(ByVal myRange As Range, ByVal Columns As Long) As String
Dim csvRangeOutput
Dim iCol As Long
Dim Entry As Variant
For Each Entry In myRange
If Not IsEmpty(Entry.Value) Then
iCol = iCol + 1
csvRangeOutput = csvRangeOutput & Entry.Value
If iCol = Columns Then
csvRangeOutput = csvRangeOutput & vbCrLf
iCol = 0
Else
csvRangeOutput = csvRangeOutput & ","
End If
End If
Next
csvRange = Left$(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
will turn this data
into comma separated values with 41 columns
1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41
42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82
83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123
124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140
Alternative
Public Sub Convert()
Const ColCount As Long = 41
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow Step ColCount
ws.Cells(iRow \ ColCount + 1, "B").Value = "'" & Join((WorksheetFunction.Transpose(ws.Range("A" & iRow).Resize(RowSize:=IIf(iRow + ColCount - 1 > LastRow, WorksheetFunction.Max(LastRow Mod ColCount, 2), ColCount)).Value)), ",")
Next iRow
End Sub
Please, test the next code. It will do what (I understood) you need, for as many records you have in column A:A. It should be fast, using arrays and working in memory. The single iteration is for the necessary number of range slices:
Private Sub testStringCSVArray()
Dim sh As Worksheet, arr, nrSlices As Long, LastRow As Long, rngF As Range
Dim rngStart As Range, i As Long, k As Long, h As Long, arrFin
Set sh = ActiveSheet
LastRow = sh.Range("A1").End(xlDown).row
LastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of A:A
arr = sh.Range("A1:A" & LastRow).Value 'put the range in an array
nrSlices = UBound(arr) \ 41 'determine the number of necessary slices
ReDim arrFin(nrSlices + 1)
Set rngStart = sh.Range("B" & UBound(arr) + 2) 'set the cell where the result to be returned
For i = 1 To nrSlices + 1
arrFin(h) = CStr(Join(Application.Transpose(Application.Index(arr, _
Evaluate("row(" & k + 1 & ":" & IIf(i <= nrSlices, 41 + k, UBound(arr)) & ")"), 1)), ","))
k = k + 41: h = h + 1
Next i
'Format the range where the processed data will be returned and drop the processed data array:
With rngStart.Resize(h, 1)
.NumberFormat = "#"
.Value = WorksheetFunction.Transpose(arrFin)
End With
End Sub
In order to avoid deleting of the already processed data, in case of whishing to run the code twice or more times, the processed data will be returned in column B:B, two rows down from the last cell in column A:A. If after testing, the code proves to be reliable and no need to run it one more time, Set rngStart = sh.Range("B" & UBound(arr) + 2) can be modified in Set rngStart = sh.Range("A" & UBound(arr) + 2).
Without preliminary formatting as text the area where the data will be dropped, Excel changes the NumberFormat in "scientific", when the comma delimited string contains (only) numbers of three digits each. It looks to consider the comma as a thousands separator...
I have a task to drag formulas in several columns based on length of one specific column (which length can vary).
I managed to do it, but had to create new line of code for each range.
Sample of my Variant 1:
Sub DragRows()
Dim LastRowEPS As Integer
Dim tr As Range
Set tr = Range("A14:G" & LastRowEPS)
Range("A14:G14").Select
Selection.AutoFill Destination:=tr, Type:=xlFillDefault
Set tr = Range("I14:K" & LastRowEPS)
Range("I14:K14").Select
Selection.AutoFill Destination:=tr, Type:=xlFillDefault
End Sub
I want to optimize my code and include several variable ranges in one line of code.
Here is my Variant 2:
Sub DragRows()
Dim LastRowEPS As Integer
Dim tr As Range
LastRowEPS = Sheet1.Cells(14, 12).End(xlDown).Row
Set tr = Range("A14:G" & LastRowEPS & ", I14:K" & LastRowEPS & ", M14:N" & LastRowEPS & ", P14:P" & LastRowEPS)
Range("A14:G14,I14:K14,M14:N14,P14:P14").Select
Selection.AutoFill Destination:=tr, Type:=xlFillDefault
End Sub
The selection process works, and tr.Range is defined properly, but VBA autofill shows Error:
Run-time error '1004': AutoFill method of Range class failed
Is it possible to include several variable ranges as destination of autofill or any other way to optimize my code?
Actually i found out a solution, which i was lookin for. Maybe for someone it will be helpful. .AutoFill is bad with multiple ranges, that's why simple use of .FillDown is an answer here:
Sub DragRows()
Dim LastRowEPS As Integer
Dim tr As Range
LastRowEPS = Sheet1.Cells(14, 12).End(xlDown).Row
Set tr = Sheet1.Range("A14:G" & LastRowEPS & ", I14:K" & LastRowEPS & ", M14:N" & LastRowEPS & ", P14:P" & LastRowEPS)
tr.FillDown
End Sub
AutoFill, Formula, FillDown
The following shows two different approaches.
OP already revealed the superior solution, which is covered in the second procedure.
Three Solutions (Inferior: Applied to Four Ranges)
Sub dragRows()
' Define constants.
Const FirstRow As Long = 14
Const LastRowCol As Long = 12
Dim Cols As Variant
Cols = Array("A:G", "I:K", "M:N", "P")
' In worksheet...
With Sheet1
' Determine Rows Count.
Dim RowsCount As Long
RowsCount = .Cells(FirstRow, LastRowCol).End(xlDown).Row - FirstRow + 1
' Declare variables
Dim rng As Range
Dim n As Long
' Define and fill each range.
For n = LBound(Cols) To UBound(Cols)
Set rng = .Columns(Cols(n)).Rows(FirstRow)
' Choose one of the following solutions
rng.AutoFill Destination:=rng.Resize(RowsCount), Type:=xlFillDefault
'rng.Resize(RowsCount).Formula = rng.Formula
'rng.Resize(RowsCount).FillDown
Next n
End With
End Sub
FillDown Solution (Superior: Applied to One Range)
Sub dragRowsFillDown()
' Define constants.
Const FirstRow As Long = 14
Const LastRowCol As Long = 12
Dim Cols As Variant
Cols = Array("A:G", "I:K", "M:N", "P")
' In worksheet...
With Sheet1
' Determine Rows Count.
Dim RowsCount As Long
RowsCount = .Cells(FirstRow, LastRowCol).End(xlDown).Row - FirstRow + 1
' Declare variables
Dim rng As Range
Dim n As Long
' Define (non-contiguous) range.
For n = LBound(Cols) To UBound(Cols)
If Not rng Is Nothing Then
Set rng = Union(rng, .Columns(Cols(n)).Rows(FirstRow) _
.Resize(RowsCount))
Else
Set rng = .Columns(Cols(n)).Rows(FirstRow).Resize(RowsCount)
End If
Next n
End With
rng.FillDown
End Sub
I need a dynamic way to add Note in which cell in my ID column A. However the comments need to use the information from Column B and C. ex: ON 01/13/2020, Anne.
I am not sure how to check how many times each value from column A will appear and use information from column D and B to create the comment (NOTE)..
result I need. All the time the ID number will be the same the comments need to be the same as well.
The code I am using is
Sub Cmt_test()
Sheet1.Range("A2").AddComment "On " & Sheet1.Range("D2") & ", " & Sheet1.Range("B2")
End Sub
I don't know how I can make it dynamic to get the information all the time the same ID appears. Maybe if I use Loop on column A would it be possible that all the time the loop finds the same ID to add the comment using the information from column D and B?
Write Comments to Each Cell in a Column
Option Explicit
Sub addComments()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const LastRowCol As Long = 1 ' or "A"
Const str1 As String = "On "
Const str2 As String = ", "
Dim Cols As Variant: Cols = Array(1, 2, 4)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow: LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
Dim Vals As Variant: ReDim Vals(UBound(Cols))
' Define Source Range.
Dim rng As Range: Set rng = ws.Range(ws.Cells(FirstRow, Cols(0)), _
ws.Cells(LastRow, Cols(0)))
' Write Column Ranges to Arrays.
Dim j As Long
For j = 0 To UBound(Cols)
Vals(j) = rng.Offset(, Cols(j) - Cols(0))
Next j
' Loop through elements (rows) of Source Array
' and write comments to a dictionary.
Dim dict As Object, Curr As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Vals(0))
Curr = Vals(0)(i, 1)
If dict(Curr) <> "" Then
dict(Curr) = dict(Curr) & vbLf & str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
Else
dict(Curr) = str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
End If
Next i
' Write comments from the dictionary to Source Range.
rng.ClearComments
Dim cel As Range
For Each cel In rng.Cells
cel.AddComment dict(cel.Value)
Next cel
End Sub
I'm trying to parse a column that contains data in the following format in each cell -
pull: test1
or
pull: test2|pull: test3|.....
or
other: blah...
I only want a grab each "Pull: test" and place 1 in each row in a new worksheet like below, and ignore any parts of the cell that don't begin with "pull: " -
pull: test1
pull: test2
pull: test3
...
What I have so far just pulls the entire column and pastes into the same spreadsheet, I'm not sure how to separate the items in each cell into their own rows. I also can't get it to pull to a different worksheet correctly either (commented out my attempt)
Sub InStrDemo()
Dim lastrow As Long
Dim i As Integer, icount As Integer
'Sheets.Add.Name = "TEST"
lastrow = ActiveSheet.Range("A10000").End(xlUp).Row
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "pull:") <> 0 Then
icount = icount + 1
'Sheets("TEST").Range("A" & icount & ":E" & icount) = Worksheets("SearchResults").Range("A" & i & ":E" & i).Value
Range("L" & icount) = Range("E" & i).Value
End If
Next i
End Sub
Untested, written on mobile.
Option Explicit
Sub testDemo()
Dim sourceSheet as worksheet
Set sourceSheet = ActiveSheet ' would be more reliable to qualify the workbook and worksheet by name'
Dim outputSheet as worksheet
Set outputSheet = thisworkbook.worksheets.add
Dim lastRow As Long
lastrow = sourceSheet.Range("A10000").End(xlUp).Row
' I assume column E needs to be parsed'
Dim arrayOfValues() as variant
arrayOfValues = sourceSheet.range("E1:E" & lastRow)
Dim rowIndex as long
Dim columnIndex as long
Dim splitString() as string
Dim cumulativeOffset as long
Dim toJoin(0 to 1) as string
toJoin(0) = "pull: test" ' Might speed up string concatenation below'
Dim outputArray() as string
With outputsheet.range("A1") ' The first row you want to start stacking from'
For rowIndex = 1 to lastRow
' Single dimensional, 0-based array'
splitString = VBA.strings.split(vba.strings.lcase$(arrayOfValues(rowIndex,1)), "pull: test",-1, vbbinarycompare)
Redim outputArray(1 to (ubound(splitString)+1), 1 to 1)
For columnIndex = lbound(splitString) to ubound(splitString)
toJoin(1) = splitString(columnIndex)
Outputarray(columnIndex+1,1) = VBA.strings.join(toJoin, vbnullstring)
Next columnIndex
'Instead of splitting upon a delimiter, then prepending the delimiter to each array element (as is done above), you could repeatedly call instr(), use mid$() to extract the sub-string, then increase the argument passed to the "Start" parameter in instr() (effectively moving from start to end of the string) -- until instr() returns 0. Then move on to the next string in the outer loop.'
.offset(cumulativeOffset,0).resize(Ubound(outputArray, 1), 1).value2 = outputArray
cumulativeOffset = cumulativeOffset + ubound(splitString)
Next rowIndex
End Sub