如何将sheet1中文字数字分离出来？

35610101

如何将sheet1中文字数字分离出来，成为sheet2中的样式？

wang-way

我来吧 给朵小花

1. Sub getInfo()
   
2.     Set wb = Application.ThisWorkbook
   
3.     Set sht = wb.Worksheets("Sheet1")
   
4.     With sht
   
5.         arr = .UsedRange.Value
   
6.     End With
   
7.     Set sht = wb.Worksheets("Sheet2")
   
8.     With sht
   
9.         For i = LBound(arr) To UBound(arr)
   
10.             For j = LBound(arr, 2) To UBound(arr, 2)
    
11.                 s = arr(i, j)
    
12.                 ar = RegToArray(s, "([一-龢]+)[\s\S]*?([\S]+)", True)
    
13.                 .Cells(i * 2 - 1, j).Value = ar(1, 1)
    
14.                 .Cells(i * 2, j).Value = "'" & ar(1, 2)
    
15.             Next j
    
16.         Next i
    
17.     End With
    
18. End Sub
    
19. Function RegToArray(ByVal text As String, ByVal pat As String, Optional getSubmatch = False) As String()
    
20.     Dim ar() As String
    
21.     Dim Reg, ms, m
    
22.     Set Reg = CreateObject("VBScript.RegExp")
    
23.     With Reg
    
24.         .Global = True
    
25.         .Ignorecase = True
    
26.         .Pattern = pat
    
27.     End With
    
28.     If Reg.Test(text) Then
    
29.         Set ms = Reg.Execute(text)
    
30.         If getSubmatch = False Then
    
31.             ReDim ar(1 To ms.Count)
    
32.             i = 0
    
33.             For Each m In ms
    
34.                 i = i + 1
    
35.                 ar(i) = m.Value
    
36.             Next m
    
37.         Else
    
38.             ReDim ar(1 To ms.Count, 1 To ms(0).submatches.Count)
    
39.             i = 0
    
40.             For Each m In ms
    
41.                 i = i + 1
    
42.                 For j = 0 To m.submatches.Count - 1
    
43.                     ar(i, j + 1) = m.submatches(j)
    
44.                 Next j
    
45.             Next m
    
46.         End If
    
47.         RegToArray = ar
    
48.     Else
    
49.         RegToArray = Array("null", "null")
    
50.     End If
    
51.     Set Reg = Nothing
    
52. End Function
    

复制代码

limonet

关键字：chr(10)

limonet

Sub limonet()
    Dim Arr As Variant, Brr As Variant, i%, j%
    Arr = Sheet1.UsedRange
    ReDim Brr(1 To UBound(Arr) * 2, 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Arr, 2)
            Arr(i, j) = Replace(Arr(i, j), Chr(10) & Chr(10), Chr(10))
            Brr(i * 2 - 1, j) = Split(Arr(i, j), Chr(10))(0)
            Brr(i * 2, j) = Split(Arr(i, j), Chr(10))(1)
        Next j
    Next i
    Range("A1").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub

cnmlgb9998

借楼练一下PQ。


PQ 处理这种问题，比起VBA，如何？？？？？？

cai2532

cnmlgb9998 发表于 2024-7-3 09:38
借楼练一下PQ。

PQ怎么打开使用？

sdytsxd991122

WPS

longwin

Sub test()
arr = Sheet1.[a1].CurrentRegion
ReDim brr(1 To UBound(arr) * 2, 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
    sr = Split(arr(i, j), Chr(10))
    brr((i - 1) * 2 + 1, j) = sr(0)
    brr((i - 1) * 2 + 2, j) = sr(UBound(sr))
    Next
Next
Sheet2.[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

木槿花西月锦绣

=TEXTSPLIT(OFFSET(A$1,INT(ROWS($1:1)/2)+1,,),,CHAR(10),TRUE)
试了试公式解法

35610101

木槿花西月锦绣 发表于 2024-7-3 17:18
=TEXTSPLIT(OFFSET(A$1,INT(ROWS($1:1)/2)+1,,),,CHAR(10),TRUE)
试了试公式解法

公式用不了，#NAME?