Question

我想知道是否有办法将具有例如6000个单词的单元格拆分为1000个单词。例如，单元格C1中的1000个单词，然后是C2中的下一个1000个单词，依此类推。

这是我到目前为止的代码。

应该拆分该代码（Cell C1）的输出，C6为1000字，C7为1000字，依此类推，直到不再有字为止。

提前谢谢！

Option Explicit
Option Base 1

Dim dStr As String, aCell As Range
Dim cet, i As Long

Sub countWords()

Application.ScreenUpdating = False
Dim iniWords As Long, lWords As Long
Dim wK As Worksheet
On Error GoTo Err

Set wK = ActiveSheet

dStr = Join(WorksheetFunction.Transpose(wK.Range("A1:A" & wK.Range("A" & Rows.Count).End(xlUp).Row).Value), " ")
'iniWords = WorksheetFunction.CountA(wK.Range("A1:A" & wK.Rows.Count))
cet = Split(dStr, " ")
iniWords = UBound(cet)

wK.Range("A1:A" & wK.Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo

'lWords = WorksheetFunction.CountA(wK.Range("A1:A" & wK.Rows.Count))

dStr = Join(WorksheetFunction.Transpose(wK.Range("A1:A" & wK.Range("A" & Rows.Count).End(xlUp).Row).Value), " ")
cet = Split(dStr, " ")

dStr = ""
For i = LBound(cet) To UBound(cet)
    If Trim(cet(i)) <> "" And InStr(dStr, Trim(cet(i))) = 0 Then
        dStr = Trim(dStr) & " " & Trim(cet(i))
    End If
Next i
dStr = Trim(dStr)

cet = Split(dStr, " ")
lWords = UBound(cet)
wK.Range("C1") = dStr

Application.ScreenUpdating = True
MsgBox "Words: " & iniWords & vbNewLine & _
        "Removed duplicates " & iniWords - lWords & vbNewLine & _
        "Remaining Words " & lWords




Exit Sub

Err:
    MsgBox "There is no data in row A"


End Sub

Answer 1

你可以用这个：

Option Explicit

Sub main()
    Const NWORDS As Long = 100 '<--| it's the number of words you want each cell to be written with. change it to your needs

    Dim strng As String
    Dim rowOffset As Long

    With Range("C1")
        strng = .Value
        rowOffset = 5 '<--| point to C7 at the first iteration
        Do
            strng = Replace(strng, " ", "|", , NWORDS) '<--| "mark" the first NWORDS with a different separator (be sure pipe ("|") is not a character you can have in your words)
            .Offset(rowOffset).Value = Replace(Left(strng, InStrRev(strng, "|") - 1), "|", " ") '<--| write first NWORDS words in current 'rowoffset' cell
            strng = Right(strng, Len(strng) - InStrRev(strng, "|"))
            rowOffset = rowOffset + 1 '<--| update row offset
        Loop While UBound(Split(strng, " ")) > NWORDS - 1
        .Offset(rowOffset).Value = strng
    End With
End Sub

Excel VBA - 将单元格拆分为1000个并将其复制到不同的单元格中

1 个答案: