Question

我有一个工作簿（C：\ DOORS.xlsx），其中包含以下数据：

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

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

QT.xlsx上的输出如下所示：

'Starting at cell D18

          A    B    C       D
  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)会将文本分成两部分（第一部分短于56个字符，第二部分将是剩下的部分） *注意：如果文本字符串超过55没有空格的字符，它将被剪切为第55个字符！

它如何找我:(没有B / C栏改变）

输入：（DOORS.xlsx）

输出：（QT.xlsx）

Answer 2

    A    B    C                      D
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

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

2 个答案: