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

debugcn 发表于 Dev

克里斯

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

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

该代码的输出（单元格 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

用户3598756

你可以用这个：

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。