Excel VBAmacros – 在循环中连接

尝试制作一个macros，它将在电子表格中每1000行插入一行，并将列的前1000行连接到不同列中第1000行的单个单元格中。

我正在使用此代码来每1000行插入一行：

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 

如果我的描述不清楚，请道歉。 这里是我想要的结果的剪辑。

任何帮助，将不胜感激。

Answer 1

编辑：添加缺less.EntireRow在标记行上

 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 

Answer 2

我会build议使用Mod运算符：

 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 

在这里阅读Mod运算符： http : //msdn.microsoft.com/en-us/library/se0w9esz.aspx

或更完全：

 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 

Answer 3

下面的代码应该给你需要的输出：

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 

结束小组