Excel VBA Macro - Loop Combine
Attempting to make a macro that will insert a row every thousandth row into a spreadsheet and insert the concatenation of the previous 1000 rows of a column into one cell of that 1000th row in another column.
I am using this code to insert a row at every thousandth row:
Sub Insert1000()
Dim rng As Range
Set rng = Range("A2")
While rng.Value <> ""
rng.Offset(1000).EntireRow.Insert
'code insert csv of 1000 previous rows into a single cell
Set rng = rng.Offset(1001)
Wend
End Sub
Sorry if my description was not clear. Here is a clip of what I would like my results to be.
Any help would be appreciated.
+3
source to share
3 answers
EDIT: Added missing .EntireRow
in the marked line
Sub InsertCSV()
Const BLOCK_SIZE As Long = 1000
Dim rng As Range, num
Set rng = Range("A2").Resize(BLOCK_SIZE)
num = Application.CountA(rng)
Do While num > 0
rng.Cells(BLOCK_SIZE + 1).EntireRow.Insert
With rng.Cells(BLOCK_SIZE + 1).EntireRow '<<edited
.Cells(1, "H").Value = Join(Application.Transpose(rng.Value), ",")
.Cells(1, "I").Value = Join(Application.Transpose(rng.Offset(0, 1).Value), ",")
End With
Set rng = rng.Offset(BLOCK_SIZE + 1)
num = Application.CountA(rng)
Loop
End Sub
+3
source to share
I would recommend using the Mod operator:
Dim x
For Each x In ActiveSheet.Range("A1:A" & ActiveSheet.UsedRange.Rows.Count)
If x.Row Mod 1000 = 0 Then
x.EntireRow.Insert
End If
Next x
Read about the Mod operator here: http://msdn.microsoft.com/en-us/library/se0w9esz.aspx
or more completely:
Dim x, y, outputText As String
For Each x In ActiveSheet.Range("A1:A" & ActiveSheet.UsedRange.Rows.Count)
outputText = outputText & x.Value
If x.Row Mod 1000 = 0 Then
x.EntireRow.Insert
x.Value = outputText
outputText = ""
End If
Next x
+1
source to share
Below code should provide the required output you are looking for:
Sub pInsert1000 ()
Dim lngLoop As Long
Dim lngTotal As Long
Dim lngCounter As Long
Dim rngRange As Range
Dim strConcatACol As String
Dim strConcatBCol As String
Set rngRange = Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious)
If Not rngRange Is Nothing Then
lngTotal = rngRange.Row
Else
lngTotal = 0
End If
lngCounter = 0
lngLoop = 1
While lngLoop < lngTotal
lngCounter = lngCounter + 1
If lngCounter = 1 Then
strConcatACol = Cells(lngLoop, 1)
strConcatBCol = Cells(lngLoop, 2)
Else
strConcatACol = strConcatACol & ", " & Cells(lngLoop, 1)
strConcatBCol = strConcatBCol & ", " & Cells(lngLoop, 2)
End If
If lngCounter = 1000 Then
Rows(lngLoop + 1).EntireRow.Insert
Cells(lngLoop + 1, 8) = strConcatACol
Cells(lngLoop + 1, 9) = strConcatBCol
lngLoop = lngLoop + 1
lngTotal = lngTotal + 1
lngCounter = 0
End If
lngLoop = lngLoop + 1
Wend
Set rngRange = Nothing
End Sub
0
source to share