需要将 Excel VBA 中的值拆分为两个单元格
Need to split the value in Excel VBA into two cells
我有一个相当简单的问题。我就是想不出我这辈子该怎么做。
我在 Excel 中有一系列单元格,如下所示:
Row ColA
1 B001
2 B002
3 B003
4 B004
5 B005
我需要知道如何在 VBA 中拆分这些单元格,以便它们现在像这样:
ColB ColC
1 B 001
2 B 002
3 B 003
4 B 004
5 B 005
我知道您在 VBA 中使用了 SPLIT 命令,但我很难知道如何填写其余部分。有人可以帮忙吗?
这是一张图片来帮助描述我在Excelhave/need
中的内容
enter image description here
解析数字文本
测试 1
Option Explicit
Sub Test1()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion.Columns(1)
' If there are headers:
'Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
Dim Data As Variant: Data = rg.Value
ReDim Preserve Data(1 To UBound(Data, 1), 1 To 2)
Dim r As Long
For r = 1 To UBound(Data, 1)
Data(r, 2) = Right(Data(r, 1), 3)
Data(r, 1) = Left(Data(r, 1), 1)
Next r
With rg.Offset(, 1).Resize(, 2)
.Columns(2).NumberFormat = "@"
.Value = Data
End With
End Sub
测试 2(不打乱数字格式)
Sub Test2()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion.Columns(1)
' If there are headers:
'Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
rg.Offset(, 1).Value = ws.Evaluate("LEFT(" & rg.Address & ",1)")
rg.Offset(, 2).Value = ws.Evaluate("""'"" & RIGHT(" & rg.Address & ",3)")
End Sub
测试 3(使用 TextToColumns
不打乱数字格式)
Sub Test3()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion.Columns(1)
' If there are headers:
'Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
'Application.DisplayAlerts = False ' overwrite without confirmation
rg.TextToColumns Destination:=rg.Offset(, 1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 2), Array(1, 2))
'Application.DisplayAlerts = True
End Sub
两个 (2
) 表示 As Text,零 (0
) 表示第一个字符(在第 0 个字符之后)和一个 (1
) 表示在第一个字符之后。
我有一个相当简单的问题。我就是想不出我这辈子该怎么做。
我在 Excel 中有一系列单元格,如下所示:
Row ColA
1 B001
2 B002
3 B003
4 B004
5 B005
我需要知道如何在 VBA 中拆分这些单元格,以便它们现在像这样:
ColB ColC
1 B 001
2 B 002
3 B 003
4 B 004
5 B 005
我知道您在 VBA 中使用了 SPLIT 命令,但我很难知道如何填写其余部分。有人可以帮忙吗?
这是一张图片来帮助描述我在Excelhave/need
中的内容enter image description here
解析数字文本
测试 1
Option Explicit
Sub Test1()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion.Columns(1)
' If there are headers:
'Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
Dim Data As Variant: Data = rg.Value
ReDim Preserve Data(1 To UBound(Data, 1), 1 To 2)
Dim r As Long
For r = 1 To UBound(Data, 1)
Data(r, 2) = Right(Data(r, 1), 3)
Data(r, 1) = Left(Data(r, 1), 1)
Next r
With rg.Offset(, 1).Resize(, 2)
.Columns(2).NumberFormat = "@"
.Value = Data
End With
End Sub
测试 2(不打乱数字格式)
Sub Test2()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion.Columns(1)
' If there are headers:
'Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
rg.Offset(, 1).Value = ws.Evaluate("LEFT(" & rg.Address & ",1)")
rg.Offset(, 2).Value = ws.Evaluate("""'"" & RIGHT(" & rg.Address & ",3)")
End Sub
测试 3(使用 TextToColumns
不打乱数字格式)
Sub Test3()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion.Columns(1)
' If there are headers:
'Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
'Application.DisplayAlerts = False ' overwrite without confirmation
rg.TextToColumns Destination:=rg.Offset(, 1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 2), Array(1, 2))
'Application.DisplayAlerts = True
End Sub
两个 (2
) 表示 As Text,零 (0
) 表示第一个字符(在第 0 个字符之后)和一个 (1
) 表示在第一个字符之后。