執行個體14-合并多個單元格資料
Private Sub CommandButton合并資料_Click()
'合并符号不能為空
With ThisWorkbook.Worksheets("操作界面")
Dim mergetext As String
If .Cells(4, "C").Value <> "" Then
mergetext = .Cells(4, "C").Value
Else
MsgBox "請輸入合并符号"
Exit Sub
End If
'合并區域不能為空
Dim mergerange As String
If .Cells(7, "C").Value <> "" Then
mergerange = .Cells(7, "C").Value
Else
MsgBox "請輸入合并區域位址"
Exit Sub
End If
'清除原結果區域
.Cells(10, "B").Value = ""
'合并資料
Dim itemcell
Dim mergeresult As String
For Each itemcell In ThisWorkbook.Worksheets("待合并資料").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
執行個體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 "參數不能為空"
Exit Sub
End If
On Error GoTo 處理出錯
'定義變量
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)
'循環判斷（反向）
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
處理出錯:
MsgBox Err.Description
End Sub