循环浏览产品列表并输出到不同的电子表格中

我有一个工作簿（C：\ DOORS.xlsx）与以下数据：

ABCD 100 ... Type A Description Remarks 102 ... Type B Description Remarks 103 ... Type C Description Remarks 

我需要创build一个循环，通过每一行输出数据到不同的工作簿（C：\ QT.xlsx）。 它需要能够确保Door和Description的值不能超过55个字符。 如果它们的长度超过55个字符，则需要将其余部分移动到下一行，而不用将单词减半。 此外，如果备注是空白的，那么这是描述应该去的地方。

在QT.xlsx上，输出将如下所示：

 'Starting at cell D18 ABCD 18 Door: 100, 100, 103, 104, 105, 19 106, 107, 108, 110, 107 20 Type A 21 Remarks A 'Text Should Be Bold 22 This is a really long description 23 and needs to fit in this space by 24 being 55 characters long and does 25 cut a word in half. 26 27 Door: 102, 100, 103, 104, 28 Type B 29 Remarks B 'Text Should Be Bold 30 Description 31 32 Door: 103, 100, 103, 104, 33 Type C 34 Description 'This is a blank cell in DOORS.xlsx 35 

我仍然在学习VBA，而且我也是新来的循环。 不知道从哪里开始，但不胜感激任何帮助。 提前致谢。

Answer 1

编辑这应该工作，因为你需要它。 但是，这是一个巨大的变化，如果有问题，只需写评论。 🙂

 Option Explicit Sub GetTheData() Dim MyWSSource As Worksheet Dim MyWSTarget As Worksheet Dim sArr As Variant Dim i As Long, j As Long, k As Byte, iLines As Long Application.ScreenUpdating = False 'will automatically set to true after the sub ends Set MyWSSource = Workbooks.Open("C:\DOORS.xlsx").Sheets(1) 'set your source wb+sheet Set MyWSTarget = Workbooks.Open("C:\QT.xlsx").Sheets(1) 'set your target wb+sheet iLines = MyWSSource.Cells(Rows.Count, 1).End(xlUp).Row 'get the last line to be processed j = 18 'set the first line to output For i = 1 To iLines For k = 1 To 4 If Len(MyWSSource.Cells(i, Array(1, 2, 4, 3)(k - 1)).Value) Then 'if cell is empty it will be skipped If k = 1 Then ' ---------- new lines start ---------- MyWSTarget.Cells(j, 2).Value = Len(MyWSSource.Cells(i, 1).Value) - Len(Replace(MyWSSource.Cells(i, 1).Value, ",", "")) + 1 'new line for count in b If Left(MyWSSource.Cells(i, 3).Value, 4) = "Pair" Then 'case sensitive 'If LCase(Left(MyWSSource.Cells(i, 3).Value, 4)) = "pair" Then 'not case sensitive MyWSTarget.Cells(j, 3).Value = "PR" Else MyWSTarget.Cells(j, 3).Value = "EA" End If ' ---------- new lines end ---------- sArr = CropText("Door: " & MyWSSource.Cells(i, 1).Value) 'sets the "Door: " for column A Else sArr = CropText(MyWSSource.Cells(i, Array(1, 2, 4, 3)(k - 1)).Value) 'the "Array(1, 2, 4, 3)(k - 1)" switches col C and D cus you want A->B->D->C End If If k = 3 Then MyWSTarget.Cells(j, 4).Font.Bold = True 'bolt Remark-line MyWSTarget.Cells(j, 4).Value = sArr(0): j = j + 1 'input text and goto next line While Len(sArr(1)) sArr = CropText(CStr(sArr(1))) If k = 3 Then MyWSTarget.Cells(j, 4).Font.Bold = True 'bolt Remark-line MyWSTarget.Cells(j, 4).Value = sArr(0): j = j + 1 'input text and goto next line Wend End If Next j = j + 1 'adds an empty line after each dataset Next MyWSSource.Parent.Close 0 'close your source (discard changes -> no changes made) MyWSTarget.Parent.Close 1 'close your target (save changes) End Sub Public Function CropText(a As String) As Variant Dim b As String, i As Long If Len(a) > 55 Then For i = 0 To 55 If Mid(a, 56 - i, 1) = " " Then CropText = Array(Left(a, 55 - i), Mid(a, 57 - i)) Exit Function End If Next CropText = Array(Left(a, 55), Mid(a, 56)) 'new line -> see *NOTE Else CropText = Array(a, "") End If End Function 

CropText(string)将文本分成2部分（第一个短于56个字符，第二个将剩下的全部） *注意 ：如果文本string超过55个字符没有空格，它将在第55个字符！

它是如何find我的:(没有列B / C变化）

input：（DOORS.xlsx）

输出：（QT.xlsx）

Answer 2

  ABCD 18 10 EA Door: 100, 100, 103, 104, 105, 19 106, 107, 108, 110, 107 20 Type A 21 Remarks A 'Text Should Be Bold 22 This is a really long description 23 and needs to fit in this space by 24 being 55 characters long and does 25 cut a word in half. 26 27 4 PR Door: 102, 100, 103, 104 28 Type B 29 Remarks B 'Text Should Be Bold 30 PAIR Description 31 32 3 EA Door: 103, 100, 103, 104 33 Type C 34 Description 'This is a blank cell in DOORS.xlsx 35