實(shí)例16-按文本查找指定列復(fù)制粘貼

Private Sub CommandButton復(fù)制粘貼_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) = "" Or Trim(.Cells(22, "C").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)

Dim copyrange As String

copyrange = Trim(.Cells(22, "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

? ? ThisWorkbook.Worksheets("復(fù)制區(qū)域").Range(copyrange).Copy

? ? ? ? .Cells(i, matchcolumn).PasteSpecial Paste:=xlPasteAll

? ? 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

實(shí)例17-多個(gè)工作表復(fù)制粘貼

Private Sub CommandButton復(fù)制粘貼_Click()

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

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

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

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

? ? ?Exit Sub

? ? ?End If

'On Error GoTo 處理出錯(cuò)

'定義變量

Dim wbname As String

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

Dim copyrange As String

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

Dim copyposition As String

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

End With

'處理表格

With Workbooks(wbname)

'循環(huán)判斷

Dim i

For i = 1 To .Worksheets.Count

? ? ThisWorkbook.Worksheets("復(fù)制區(qū)域").Range(copyrange).Copy .Worksheets(i).Range(copyposition)

Next i

End With

Workbooks(wbname).Save

MsgBox "處理完成"

Workbooks(wbname).Activate

Exit Sub

處理出錯(cuò):

MsgBox Err.Description

End Sub