實例25-多種類型復(fù)制粘貼

1

粘貼全部內(nèi)容。

2

粘貼除邊框外的全部內(nèi)容。

3

將粘貼所有內(nèi)容，并且將合并條件格式。

4

使用源主題粘貼全部內(nèi)容。

5

粘貼復(fù)制的列寬。

6

粘貼批注。

7

粘貼復(fù)制的源格式。

8

粘貼公式。

9

粘貼公式和數(shù)字格式。

10

粘貼有效性。

11

粘貼值。

12

粘貼值和數(shù)字格式。

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(14, "C").Value) = "" Then

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

Exit Sub

End If

'On Error GoTo 處理出錯

'定義變量

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)

Dim copytypenum As Integer

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

End With

'處理表格

With Workbooks(wbname)

'循環(huán)判斷

Dim i

For i = 1 To .Worksheets.Count

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

Select Case copytypenum

Case 1

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 2

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 3

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteAllMergingConditionalFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 4

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 5

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 6

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 7

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 8

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 9

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 10

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 11

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Case 12

.Worksheets(i).Range(copyposition).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End Select

Next i

End With

Workbooks(wbname).Save

MsgBox "處理完成"

Workbooks(wbname).Activate

Exit Sub

處理出錯:

MsgBox Err.Description

End Sub

實例26-對比兩表不同

Private Sub CommandButton對比_Click()

Dim comparerange As String

If ThisWorkbook.Worksheets("操作界面").Cells(2, "C").Value <> "" Then

comparerange = ThisWorkbook.Worksheets("操作界面").Cells(2, "C").Value

Else

MsgBox "對比區(qū)域地址不能為空"

Exit Sub

End If

'對比

Dim cellitem1

For Each cellitem1 In ThisWorkbook.Worksheets("表1").Range(comparerange)

If cellitem1.Value <> ThisWorkbook.Worksheets("表2").Range(cellitem1.Address).Value Then

'標(biāo)記顏色

ThisWorkbook.Worksheets("表1").Range(cellitem1.Address).Interior.ColorIndex = 3

ThisWorkbook.Worksheets("表2").Range(cellitem1.Address).Interior.ColorIndex = 4

End If

Next cellitem1

MsgBox "對比完成"

End Sub