셀 내용을 해당 열과 함께 별도의 행으로 나눕니다.

Question

길이가 72보다 큰 셀 내용을 길이가 72자를 넘지 않는 별도의 행으로 분할하려고합니다. 그러나 각 셀의 일련 번호를 72 문자로 나누는 동안이 일련 번호를 어떻게 반복 할 수 있습니까? 예를 들어 144 개의 문자와 일련 번호 S1이 다른 열에 할당 된 경우, 위의 모듈을 사용하여 텍스트를 2 개의 셀로 나누면 같은 일련 번호 S1이 새 셀마다 복사됩니다. 우리가 할 수 있을까요? 코드는 다음과 같습니다.

어떤 제안이?

Link to code

감사

Answer 1

이제 사용자 입력 데이터의 예를 제공하는 출력을 소망 한 것으로, 여기에서 이전에 제공된 코드에 저장하는 루틴을 수정하는 작업을 수행하는 한 가지 방법이다.

첫 번째 차원의 크기를 변경하는 배열을 Redim Preserve 할 수 없으므로 Collection 개체를 사용하여 모든 개별 줄을 수집 한 다음 결과 배열의 크기를 지정하고 별도의 단계로 채 웁니다.

일부 가정은 원본 데이터가 1 ​​열 A 열에 C 열에 있고 결과가 sheet2에 기록된다는 것입니다.

코드를 살펴보고 각 단계에서 진행되는 작업을 이해하십시오. 뭔가가 왜 다른쪽으로 이루어 졌는지에 대해 명확하게 질문하십시오.

---

Option Explicit 
Sub WordWrap2() 
'requires reference to Microsoft VBScript Regular Expressions 5.5 
'Wraps at W characters, but will allow overflow if a word is longer than W 
Dim RE As RegExp, MC As MatchCollection, M As Match 
Dim str As String 
Const W As Long = 72 

Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range 
Dim vSrc As Variant 
Dim vRes() As Variant 'Results 
Dim colLines As Collection 
Dim vLine(1 To 3) As Variant 'to store each line in collection 
Dim I As Long 

'Set source to column A:C 
' A = Sequence 
' B = ID 
' C = TXLINE2 
Set wsSrc = Worksheets("sheet1") 
Set wsRes = Worksheets("sheet2") 
    Set rRes = wsRes.Cells(1, 1) 

With wsSrc 
    vSrc = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp)) 
End With 

Set RE = New RegExp 
    RE.Global = True 

    'Cycle through third column only, and collect the data 
    Set colLines = New Collection 
    For I = 1 To UBound(vSrc, 1) 
     str = vSrc(I, 3) 

     'remove all line feeds and nbsp 
     RE.Pattern = "[\xA0\r\n\s]+" 
     str = RE.Replace(str, " ") 
     RE.Pattern = "\S.{0," & W - 1 & "}(?=\s|$)|\S{" & W & ",}" 

     If RE.Test(str) = True Then 
      Set MC = RE.Execute(str) 

      'Collect the lines, along with Seq and ID 
      For Each M In MC 
       vLine(1) = vSrc(I, 1) 
       vLine(2) = vSrc(I, 2) 
       vLine(3) = M 
       colLines.Add vLine 
      Next M 
     Else 'Allow preservation of blank lines in source data 
      Erase vLine 
      colLines.Add vLine 
    End If 
Next I 

'create results array 
ReDim vRes(1 To colLines.Count, 1 To 3) 

'Note that column headers are carried over from source data 

'Populate with the data 
For I = 1 To colLines.Count 
    vRes(I, 1) = colLines(I)(1) 
    vRes(I, 2) = colLines(I)(2) 
    vRes(I, 3) = colLines(I)(3) 
Next I 

Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) 
With rRes 
    .EntireColumn.Clear 
    .Value = vRes 
    With .Rows(1) 
     .Font.Bold = True 
     .HorizontalAlignment = xlCenter 
    End With 
    .EntireColumn.AutoFit 
End With 

Set RE = Nothing 
End Sub 

---

전 :

후 :

당신이 코드를 수정하려고 할 때로 실행 않았다 어떤 문제

Answer 2

한 간단한 방법 새로운 세포가 추가로 증가 범위를 만들고, 새로운 모든 셀을 만든 후 다음 범위를 통해 실행하고 추가하는 것입니다 적절한 일련 번호. 따라서 일련 번호가 셀 (1,2)에 있다고 가정하면 (쉽게 조정할 수 있지만) 원래 처리 루프에 추가합니다.

Dim finalRange As Range 
Set finalRange = ActiveSheet.Range(Cells(1,2).Address) 

'Now inside the loop: 
Set finalRange = Union(finalRange,newCellLocation) ' where newCellLocation is where the next line of characters has been placed 

'After the loop is complete 
For Each cell In finalRange 
If cell.Address <> ActiveSheet.Cells(1,2).Address Then 
cell.value = ActiveSheet.cells(1,2).Value & ": " & cell.Value 
'Note, adjust the string values to your desired format, this is just a placeholder 
End If 
Next Cell