在同一单元格的每一行之后添加文本

我有以下Excel单元格：

D001 D002 D003 345 

（在同一个单元格中）

我需要在同一个单元格的每一行之后添加一个文本string，如下所示：

 D001 First Text D0002 Second Text D003 Third Text 345 Fouth Text 

我find了一个代码，可以让我计算同一个单元格上有多less行，但是我没有find任何方法来使用它来写入每行上的文本：

 Public Sub CountLines() Dim H1 As Double Dim H2 As Double Dim row As Long row = 1 While Cells(row, 1).Value <> "" With Cells(row, 1) .WrapText = False H1 = .height .WrapText = True H2 = .height .Offset(0, 1).Value = H2 / H1 End With row = row + 1 Wend End Sub 

我猜这样做的正确方法是在VBA上find（Ch（10））的任何行更改之前使用For写入文本，但是我还没有能够使其工作

谢谢您的帮助。

Answer 1

添加文本来计算换行符

这段代码将循环遍历列A中任何值的所有单元格。我已经在Excel中重新创build了您的数据集：

代码将打破每一行，添加它是哪一行，然后转到下一行：

以下是代码：

 Sub AddText() Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1) Dim myCell As Variant, myRange As Range, tempArr() As String Dim i As Integer Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)) For Each myCell In myRange tempArr = Split(myCell, Chr(10)) myCell.Value = "" For i = 0 To UBound(tempArr) tempArr(i) = tempArr(i) & " text " & i If i = UBound(tempArr) Then myCell.Value = myCell.Value & tempArr(i) Else: myCell.Value = myCell.Value & tempArr(i) & Chr(10) End If Next i Next myCell End Sub 

---

如果您希望它从基数1而不是基数0开始计数，请将myCell.Value = myCell.Value & tempArr(i) （以及If语句中的以下内容myCell.Value = myCell.Value & tempArr(i)的行更改为myCell.Value = myCell.Value & tempArr(i) + 1

---

我应该再次提到，这已经在列A中设置了一个dynamic范围。意思是如果在A2添加更多格式相同的数据，代码也将自己应用于该数据，直到最后一组数据在A栏中

Answer 2

Dim arr（）As String Dim arr2（）As String

arr = Split（yourCell，char（10））arr2 = Split（“first，second，third”，“，”）

对于i = 1到UBound（arr）debugging。 打印arr（i）+ arr2（i）next i

在重build新string之后，新string将其分配回单元格

Answer 3

这只会在单元格中的每行之后放置（随机）文本。 但它给你一个开始的地方。

 Option Explicit Public Sub RePrint() Dim MyRange As Range Dim MyArray As Variant Dim i As Long Set MyRange = Range("A1") MyArray = Split(MyRange, Chr(10)) For i = LBound(MyArray) To UBound(MyArray) MyArray(i) = MyArray(i) & " Text" & i Next i MyRange = Join(MyArray, Chr(10)) End Sub 

Answer 4

你可以使用这个function：

 Function AddText(rng As Range, textsArr As Variant) As String Dim nTexts As Long, nLines As Long, iLine As Long Dim linesArr As Variant nTexts = UBound(textsArr) - LBound(textsArr) + 1 With rng linesArr = Split(.Value, vbLf) nLines = UBound(linesArr) - LBound(linesArr) + 1 If nTexts < nLines Then nLines = nTexts For iLine = 1 To nLines linesArr(LBound(linesArr) - 1 + iLine) = linesArr(LBound(linesArr) - 1 + iLine) & " " & textsArr(LBound(textsArr) - 1 + iLine) Next iLine AddText = Join(linesArr, vbLf) End With End Function 

被利用如下

 Option Explicit Sub main() Dim cell As Range Dim additionalTexts As Variant additionalTexts = Array("First Text", "Second Text", "Third Text", "Fourth Text") '<--| set your array of additional text, each element index corresponding to to be processed cell content line With Worksheets("ADDTEXT") '<--| reference your relevant worksheet (change "ADDTEXT" to your actual relevant worksheet name) For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column "A" cells form row 1 down to last not empty row cell.Value = AddText(cell, additionalTexts) '<--| process Next cell End With End Sub 

Answer 5

这将在文本“第一行”，“第二行”…每行之后。 现在设置的方式使用A1的值并replaceA1的值。 对于4行或更less的电池是理想的，但是它可以工作得更多。

 Sub appendCharacters() Dim lines() As String Dim text As String lines = Split(Range("A1"), Chr(10)) Range("A1").Value = "" For i = LBound(lines) To UBound(lines) Select Case i Case 0 text = " First Line" Case 1 text = " Second Line" Case 2 text = " Third Line" Case 3 text = " Fourth Line" Case Else text = " Another Line" End Select lines(i) = lines(i) + text Range("A1").Value = Range("A1").Value + lines(i) If i <> UBound(lines) Then Range("A1").Value = Range("A1").Value + vbCrLf End If Next i End Sub