excel里的拆分合并,有没有人这样操作

最近在做一个电力的项目划分，一个单元格内好几个部位，类似于这种；

如果放到其他表格，还需要一个个复制，特别麻烦，想偷懒的我突然想到，当年刚开始做公众号的时候编写的一个操作，非常合适，简直完美，我先放个截图，看看有几个人用过；，如果感觉有用，我会发到群里

已关注

关注

重播分享赞

视频详情

关键代码我也放到下面，；

Private Sub CommandButton1_Click()

' 合并单元格保留所有内容内容

Dim strText As String

Dim rngCell As Range

Dim fengefu As String

On Error Resume Next

'TextBox1.Text = Application.InputBox(Prompt:="输入分隔符，比如、，\，", Type:=2)

If TypeName(Selection) = "Range" Then

For Each rngCell In Selection

strText = strText & rngCell.Value & TextBox1.text

Next rngCell

Application.DisplayAlerts = False

Selection.Merge

Selection.Value = Left(strText, Len(strText) - 1)

Application.DisplayAlerts = True

End If

Set rngCell = Nothing

End Sub

Private Sub CommandButton2_Click()

' 保留原格式

Dim strText As String

Dim rngCell As Range

Dim lie As Integer, heng As Integer

Dim fengefu As String

Dim arr

On Error Resume Next

Set rngCell = ThisWorkbook.Worksheets(1).Cells(1, 1)

'‘fengefu = Application.InputBox(Prompt:="输入分隔符，比如、，\，", Type:=2)

If TypeName(Selection) = "Range" Then

arr = Selection.Value

For heng = LBound(arr, 1) To UBound(arr, 1)

For lie = LBound(arr, 2) To UBound(arr, 2)

strText = strText & arr(heng, lie) & TextBox1.text

If heng < UBound(arr, 1) Then

rngCell = rngCell & VBA.Left(strText, VBA.Len(strText) - 1) & VBA.Chr(10)

Else

rngCell = rngCell & Left(strText, Len(strText) - 1)

End If

strText = ""

Application.DisplayAlerts = False

Selection.Merge

Selection.Value = rngCell

rngCell.ClearContents

Application.DisplayAlerts = True

End If

Set rngCell = Nothing

End Sub

Private Sub CommandButton3_Click() '拆分字符

Dim arr As Variant, m As String

Dim rng As Range, rngs As Range, rng1 As Range

Dim i As Integer, j As Integer

On Error Resume Next

Set rngs = Intersect(Selection, ActiveSheet.UsedRange)

If rngs Is Nothing Then Exit Sub

Set rng1 = Range(TextBox2.text)

For Each rng In rngs

If rng.Value <> "" Then

arr = Split(rng.Value, TextBox3.text)

For i = LBound(arr) To UBound(arr)

Cells(rng1.row + j, rng1.column + i) = arr(i)

Erase arr

End If

j = j + 1

Unload UserForm12

Set rng1 = Nothing

Set rng = Nothing

Set rngs = Nothing

End Sub

Private Sub CommandButton4_Click()

Dim arr As Variant

Dim a As Integer, rng As Range, n As Range, r As String

Dim rngs As Range

Dim i As Integer, lie As Integer

On Error Resume Next

Set rngs = Intersect(Selection, ActiveSheet.UsedRange) '合并区域选择

If rngs Is Nothing Then Exit Sub

arr = rngs.Value

rn1 = Range(TextBox2.text).row

For i = LBound(arr, 1) To UBound(arr, 1)

For lie = LBound(arr, 2) To UBound(arr, 2)

'如果单元格不为空，则进行，否则跳过

If arr(i, lie) <> "" Then

If lie < UBound(arr, 2) Then

r = r & arr(i, lie) & TextBox3.text

Else

r = r & arr(i, lie)

End If

Next lie

Cells(rn1, Range(TextBox2.text).column) = r

r = ""

rn1 = rn1 + 1

Next i

Set n = Nothing

Set rng = Nothing

End Sub

Private Sub CommandButton5_Click()

Dim arr As Variant

Dim a As Integer, rng As Range, n As Range, r As String

Dim i As Integer, lie As Integer

On Error Resume Next

Set rngs = Intersect(Selection, ActiveSheet.UsedRange) '合并区域选择

If rngs Is Nothing Then Exit Sub

arr = rngs.Value

rn1 = Range(TextBox2.text).row

For i = LBound(arr, 1) To UBound(arr, 1)

For lie = LBound(arr, 2) To UBound(arr, 2)

'如果单元格不为空，则进行，否则跳过

If arr(i, lie) <> "" Then

If lie < UBound(arr, 2) Then

r = r & arr(i, lie) & TextBox3.text

Else

r = r & arr(i, lie)

End If

Next lie

If i < UBound(arr, 1) Then

Range(TextBox2.text) = Range(TextBox2.text) & r & Chr(10)

Else

Range(TextBox2.text) = Range(TextBox2.text) & r

End If

r = ""

Next i

Set n = Nothing

Set rng = Nothing

End Sub

Private Sub CommandButton6_Click() '两个数据区域排列组合

Dim rn As Range, rn1 As Range

Dim rng As Range, rngs As Range, n As Range

Dim j As Integer, row1 As Integer

Dim str As String, str1 As String

Dim arr, arr1

Dim coll As New Collection

If TextBox4.text = "" Or TextBox5.text = "" Or TextBox6.text = "" Then MsgBox "文本框不为空": Exit Sub

Set rng = Range(TextBox4.text)

Set rngs = Range(TextBox5.text)

Set n = Range(TextBox6.text)

For Each rn In rng

For Each rn1 In rngs

str = rn & rn1

coll.Add str

row1 = n.row

For j = 1 To coll.count

Cells(row1, n.column) = coll.Item(j)

row1 = row1 + 1

Set n = Nothing

Set rng = Nothing

Set rngs = Nothing

Set coll = Nothing

End Sub

Private Sub CommandButton7_Click() '多列转换成单列

Dim n As Range

Dim arr

Dim lie As Integer, heng As Integer, row1 As Integer

Dim str As String

If TextBox7.text = "" Or TextBox8.text = "" Then MsgBox "文本框不为空": Exit Sub

Set n = Range(TextBox8.text)

arr = Range(TextBox7.text)

row1 = n.row

For lie = LBound(arr, 2) To UBound(arr, 2)

For heng = LBound(arr, 1) To UBound(arr, 1)

Cells(row1, n.column) = arr(heng, lie)

row1 = row1 + 1

Set n = Nothing

Set rng = Nothing

End Sub

Private Sub CommandButton8_Click() '按列拆分，方便查重

Dim arr As Variant

Dim rng As Range, rngs As Range, rng1 As Range

Dim i As Integer, m As Integer

On Error Resume Next

Set rngs = Intersect(Selection, ActiveSheet.UsedRange)

If rngs Is Nothing Then Exit Sub

Set rng1 = Range(TextBox2.text)

m = rng1.row

For Each rng In rngs

If rng.Value <> "" Then

arr = Split(rng.Value, TextBox3.text)

For i = LBound(arr) To UBound(arr)

Cells(m, rng1.column) = arr(i)

m = m + 1

Erase arr '移除数组

End If

Unload UserForm12

Set rng = Nothing

Set rngs = Nothing

End Sub

Private Sub CommandButton9_Click() '左边全部完成，多对一

Dim rn As Range, rn1 As Range

Dim rng As Range, rngs As Range, n As Range

Dim j As Integer, row1 As Integer

Dim str As String, str1 As String

Dim arr, arr1

Dim coll As New Collection

If TextBox4.text = "" Or TextBox5.text = "" Or TextBox6.text = "" Then MsgBox "文本框不为空": Exit Sub

Set rng = Range(TextBox4.text) '数据区1

Set rngs = Range(TextBox5.text) '数据区2

Set n = Range(TextBox6.text) '数据区3

For Each rn In rngs '数据区2

For Each rn1 In rng '数据区1

str = rn1 & rn

coll.Add str

row1 = n.row

For j = 1 To coll.count

Cells(row1, n.column) = coll.Item(j)

row1 = row1 + 1

Set n = Nothing

Set rng = Nothing

Set rngs = Nothing

Set coll = Nothing

End Sub

Private Sub TextBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.Hide

On Error Resume Next

TextBox2.text = Application.InputBox(Prompt:="选择输出区域，一个单元格即可", title:="选择区域", Type:=8).Address

Me.Show

End Sub

Private Sub TextBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.Hide

On Error Resume Next

TextBox4.text = Intersect(Application.InputBox(Prompt:="选择数据区域", Type:=8), ActiveSheet.UsedRange).Address

Me.Show

End Sub

Private Sub TextBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.Hide

On Error Resume Next

TextBox5.text = Intersect(Application.InputBox(Prompt:="选择数据区域", Type:=8), ActiveSheet.UsedRange).Address

Me.Show

End Sub

Private Sub TextBox6_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.Hide

On Error Resume Next

TextBox6.text = Application.InputBox(Prompt:="选择输出区域，一个单元格即可", title:="选择区域", Type:=8).Address

Me.Show

End Sub

Private Sub TextBox7_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.Hide

On Error Resume Next

TextBox7.text = Application.InputBox(Prompt:="选择输出区域，一个单元格即可", title:="选择区域", Type:=8).Address

Me.Show

End Sub

Private Sub TextBox8_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.Hide

On Error Resume Next

TextBox8.text = Application.InputBox(Prompt:="选择输出区域，一个单元格即可", title:="选择区域", Type:=8).Address

Me.Show

End Sub

Private Sub UserForm_Initialize()

TextBox2.text = "双击文本框"

End Sub