實例33-表內(nèi)單元格數(shù)據(jù)交換，實例34-多個工作表查找替換
實例33-表內(nèi)單元格數(shù)據(jù)交換
Private Sub CommandButton處理_Click()
Dim wbname As String
Dim cell1 As String
Dim cell2 As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Or .Cells(6, "C").Value <> "" Or .Cells(10, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
cell1 = .Cells(6, "C").Value
cell2 = .Cells(10, "C").Value
Else
MsgBox "請輸入工作簿名稱（包含擴展名），單元格1地址，單元格2地址"
Exit Sub
End If
End With
With ThisWorkbook.Worksheets("名稱列表")
Dim i As Long
Dim imax As Long
Dim shtname As String
imax = .Cells(1000000, 1).End(xlUp).Row
Dim changedata As String
For i = 1 To imax
If .Cells(i, 1).Value <> "" Then
shtname = .Cells(i, 1).Value
With Workbooks(wbname).Worksheets(shtname)
changedata = .Range(cell1)
.Range(cell1) = .Range(cell2)
.Range(cell2) = changedata
End With
End If
Next i
End With
Workbooks(wbname).Save
MsgBox "處理完成"
End Sub
Private Sub CommandButton獲取_Click()
'獲取工作簿中包含的工作表
With ThisWorkbook.Worksheets("名稱列表") '清除原列表數(shù)據(jù)
.Columns(1).ClearFormats
.Columns(1).ClearContents
End With
Dim wbname As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "請輸入工作簿名稱（包含擴展名）"
Exit Sub
End If
End With
Dim i As Integer
For i = 1 To Workbooks(wbname).Worksheets.Count
ThisWorkbook.Worksheets("名稱列表").Cells(i, 1).Value = Workbooks(wbname).Worksheets(i).Name
Next i
ThisWorkbook.Worksheets("名稱列表").Activate
End Sub
實例34-多個工作表查找替換
Private Sub CommandButton處理_Click()
Dim wbname As String
Dim findrange As String
Dim finddata As String
Dim replacedata As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Or .Cells(6, "C").Value <> "" Or .Cells(10, "C").Value <> "" Or .Cells(14, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
findrange = .Cells(6, "C").Value
finddata = .Cells(10, "C").Value
replacedata = .Cells(14, "C").Value
Else
MsgBox "請輸入工作簿名稱（包含擴展名），查找區(qū)域，查找值，替換值"
Exit Sub
End If
End With
With ThisWorkbook.Worksheets("名稱列表")
Dim i As Long
Dim imax As Long
Dim shtname As String
imax = .Cells(1000000, 1).End(xlUp).Row
Dim changedata As String
For i = 1 To imax
If .Cells(i, 1).Value <> "" Then
shtname = .Cells(i, 1).Value
With Workbooks(wbname).Worksheets(shtname)
Dim cellitem
For Each cellitem In .Range(findrange)
If cellitem.Value <> "" And cellitem.Value = finddata Then
.Range(cellitem.Address).Value = replacedata
End If
Next
End With
End If
Next i
End With
Workbooks(wbname).Save
MsgBox "處理完成"
End Sub
Private Sub CommandButton獲取_Click()
'獲取工作簿中包含的工作表
With ThisWorkbook.Worksheets("名稱列表") '清除原列表數(shù)據(jù)
.Columns(1).ClearFormats
.Columns(1).ClearContents
End With
Dim wbname As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "請輸入工作簿名稱（包含擴展名）"
Exit Sub
End If
End With
Dim i As Integer
For i = 1 To Workbooks(wbname).Worksheets.Count
ThisWorkbook.Worksheets("名稱列表").Cells(i, 1).Value = Workbooks(wbname).Worksheets(i).Name
Next i
ThisWorkbook.Worksheets("名稱列表").Activate
End Sub
