實(shí)例14-合并多個(gè)單元格數(shù)據(jù)

Private Sub CommandButton合并數(shù)據(jù)_Click()

'合并符號(hào)不能為空

With ThisWorkbook.Worksheets("操作界面")

Dim mergetext As String

If .Cells(4, "C").Value <> "" Then

mergetext = .Cells(4, "C").Value

Else

MsgBox "請(qǐng)輸入合并符號(hào)"

Exit Sub

End If

'合并區(qū)域不能為空

Dim mergerange As String

If .Cells(7, "C").Value <> "" Then

mergerange = .Cells(7, "C").Value

Else

MsgBox "請(qǐng)輸入合并區(qū)域地址"

Exit Sub

End If

'清除原結(jié)果區(qū)域

.Cells(10, "B").Value = ""

'合并數(shù)據(jù)

Dim itemcell

Dim mergeresult As String

For Each itemcell In ThisWorkbook.Worksheets("待合并數(shù)據(jù)").Range(mergerange)

If itemcell.Value <> "" Then

If mergeresult <> "" Then

mergeresult = mergeresult & mergetext & itemcell.Value

Else

mergeresult = itemcell.Value

End If

End If

Next

.Cells(10, "B").Value = mergeresult

End With

End Sub

實(shí)例15-按文本查找指定列插入空行

Private Sub CommandButton插入_Click()

'判斷工作簿名，工作表名不為空

With ThisWorkbook.Worksheets("操作界面")

If Trim(.Cells(2, "C").Value) = "" Or Trim(.Cells(6, "C").Value) = "" Or Trim(.Cells(10, "C").Value) = "" _

Or Trim(.Cells(18, "C").Value) = "" Or Trim(.Cells(14, "C").Value) = "" Or Trim(.Cells(14, "D").Value) = "" Then

MsgBox "參數(shù)不能為空"

Exit Sub

End If

On Error GoTo 處理出錯(cuò)

'定義變量

Dim wbname As String

Dim shname As String

wbname = Trim(.Cells(2, "C").Value)

shname = Trim(.Cells(6, "C").Value)

Dim matchcolumn As Long

Dim startnum As Long

Dim stopnum As Long

matchcolumn = Trim(.Cells(10, "C").Value)

startnum = Trim(.Cells(14, "C").Value)

stopnum = Trim(.Cells(14, "D").Value)

Dim matchtext As String

matchtext = Trim(.Cells(18, "C").Value)

End With

'處理表格

With Workbooks(wbname).Worksheets(shname)

'循環(huán)判斷（反向）

Dim i

For i = stopnum To startnum Step -1

If .Cells(i, matchcolumn) <> "" And .Cells(i, matchcolumn) = matchtext Then

.Rows(i).Insert

End If

Next i

End With

Workbooks(wbname).Save

MsgBox "處理完成"

Workbooks(wbname).Activate

ActiveWindow.WindowState = xlMaximized

Workbooks(wbname).Worksheets(shname).Activate

Workbooks(wbname).Worksheets(shname).Cells(1, 1).Select

Exit Sub

處理出錯(cuò):

MsgBox Err.Description

End Sub