實例35-兩表匹配，實例36-根據(jù)輸入值自動填充數(shù)據(jù) Excel表格VBA編程實例 代碼分享
實例35-兩表匹配
Private Sub CommandButton匹配1_Click()
'判斷參數(shù)不為空
Dim mc1 As Long
Dim mc2 As Long
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
mc1 = .Cells(2, "C").Value
Else
MsgBox "請輸入表1匹配列"
Exit Sub
End If
If .Cells(6, "C").Value <> "" Then
mc2 = .Cells(6, "C").Value
Else
MsgBox "請輸入表2匹配列"
Exit Sub
End If
End With
'清除匹配結(jié)果
With ThisWorkbook.Worksheets("匹配結(jié)果") '清除原列表數(shù)據(jù)
.UsedRange.ClearFormats
.UsedRange.ClearContents
End With
'獲取表1表2最大列號行號
Dim cmax1 As Long
Dim cmax2 As Long
cmax1 = ThisWorkbook.Worksheets("表1").UsedRange.Cells(ThisWorkbook.Worksheets("表1").UsedRange.Count).Column
cmax2 = ThisWorkbook.Worksheets("表2").UsedRange.Cells(ThisWorkbook.Worksheets("表2").UsedRange.Count).Column
Dim rmax1 As Long
Dim rmax2 As Long
rmax1 = ThisWorkbook.Worksheets("表1").UsedRange.Cells(ThisWorkbook.Worksheets("表1").UsedRange.Count).Row
rmax2 = ThisWorkbook.Worksheets("表2").UsedRange.Cells(ThisWorkbook.Worksheets("表2").UsedRange.Count).Row
Dim i, j
Dim addrow As Long
addrow = 1
Dim matchtext1 As String
Dim matchtext2 As String
Dim a1 As Integer '判斷循環(huán)時是否匹配成功
With ThisWorkbook.Worksheets("匹配結(jié)果") '清除原列表數(shù)據(jù)
For i = 1 To rmax2
a1 = 0
With ThisWorkbook.Worksheets("表2")
If .Cells(i, mc2) <> "" Then
matchtext2 = .Cells(i, mc2)
.Range(.Cells(i, 1), .Cells(i, cmax2)).Copy ThisWorkbook.Worksheets("匹配結(jié)果").Cells(addrow, 1)
With ThisWorkbook.Worksheets("表1")
For j = 1 To rmax1
If .Cells(j, mc1) <> "" Then
matchtext1 = .Cells(j, mc1)
If matchtext1 = matchtext2 Then
.Range(.Cells(j, 1), .Cells(j, cmax1)).Copy ThisWorkbook.Worksheets("匹配結(jié)果").Cells(addrow, cmax2 + 1)
a1 = 1
addrow = addrow + 1
End If
End If
Next j
End With
If a1 = 0 Then
addrow = addrow + 1
End If
End If
End With
Next i
End With
ThisWorkbook.Worksheets("匹配結(jié)果").Activate
End Sub
Private Sub CommandButton匹配2_Click()
'判斷參數(shù)不為空
Dim mc1 As Long
Dim mc2 As Long
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
mc1 = .Cells(2, "C").Value
Else
MsgBox "請輸入表1匹配列"
Exit Sub
End If
If .Cells(6, "C").Value <> "" Then
mc2 = .Cells(6, "C").Value
Else
MsgBox "請輸入表2匹配列"
Exit Sub
End If
End With
'清除匹配結(jié)果
With ThisWorkbook.Worksheets("匹配結(jié)果") '清除原列表數(shù)據(jù)
.UsedRange.ClearFormats
.UsedRange.ClearContents
End With
'獲取表1表2最大列號
Dim cmax1 As Long
Dim cmax2 As Long
cmax1 = ThisWorkbook.Worksheets("表1").UsedRange.Cells(ThisWorkbook.Worksheets("表1").UsedRange.Count).Column
cmax2 = ThisWorkbook.Worksheets("表2").UsedRange.Cells(ThisWorkbook.Worksheets("表2").UsedRange.Count).Column
Dim rmax1 As Long
Dim rmax2 As Long
rmax1 = ThisWorkbook.Worksheets("表1").UsedRange.Cells(ThisWorkbook.Worksheets("表1").UsedRange.Count).Row
rmax2 = ThisWorkbook.Worksheets("表2").UsedRange.Cells(ThisWorkbook.Worksheets("表2").UsedRange.Count).Row
Dim i, j
Dim addrow As Long
addrow = 1
Dim matchtext1 As String
Dim matchtext2 As String
Dim a1 As Integer '判斷循環(huán)時是否匹配成功
With ThisWorkbook.Worksheets("匹配結(jié)果") '清除原列表數(shù)據(jù)
For i = 1 To rmax1
a1 = 0
With ThisWorkbook.Worksheets("表1")
If .Cells(i, mc1) <> "" Then
matchtext1 = .Cells(i, mc1)
.Range(.Cells(i, 1), .Cells(i, cmax1)).Copy ThisWorkbook.Worksheets("匹配結(jié)果").Cells(addrow, 1)
With ThisWorkbook.Worksheets("表2")
For j = 1 To rmax2
If .Cells(j, mc2) <> "" Then
matchtext2 = .Cells(j, mc2)
If matchtext1 = matchtext2 Then
.Range(.Cells(j, 1), .Cells(j, cmax2)).Copy ThisWorkbook.Worksheets("匹配結(jié)果").Cells(addrow, cmax1 + 1)
a1 = 1
addrow = addrow + 1
End If
End If
Next j
End With
If a1 = 0 Then
addrow = addrow + 1
End If
End If
End With
Next i
End With
ThisWorkbook.Worksheets("匹配結(jié)果").Activate
End Sub
實例36-根據(jù)輸入值自動填充數(shù)據(jù)
Private Sub Worksheet_Change(ByVal Target As Range)
With ThisWorkbook.Worksheets("出庫表")
If Target.Column = 3 And Target.Row >= 6 And Target.Row <= 10 Then
Dim row1 As Long
row1 = Target.Row
If Target <> "" Then
Dim i
For i = 1 To ThisWorkbook.Worksheets("商品列表").Cells(1000000, 1).End(xlUp).Row
If Target.Value = ThisWorkbook.Worksheets("商品列表").Cells(i, 1) Then
.Cells(row1, 4) = ThisWorkbook.Worksheets("商品列表").Cells(i, 2)
.Cells(row1, 5) = ThisWorkbook.Worksheets("商品列表").Cells(i, 4)
Exit Sub
End If
Next i
MsgBox "未找到對應商品"
Target = ""
.Cells(row1, 4) = ""
.Cells(row1, 5) = ""
Else
.Cells(row1, 4) = ""
.Cells(row1, 5) = ""
End If
End If
End With
End Sub
