当前页面 ： 首页 > 快讯 > 正文 >

世界热推荐：实例35-两表匹配，实例36-根据输入值自动填充数据 Excel表格VBA编程实例 代码分享

来源：哔哩哔哩 时间： 2023-03-11 11:55:09

实例35-两表匹配

Private Sub CommandButton匹配1_Click()

'判断参数不为空


(相关资料图)

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

'清除匹配结果

With ThisWorkbook.Worksheets("匹配结果") '清除原列表数据

.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 '判断循环时是否匹配成功

With ThisWorkbook.Worksheets("匹配结果") '清除原列表数据

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("匹配结果").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("匹配结果").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("匹配结果").Activate

End Sub

Private Sub CommandButton匹配2_Click()

'判断参数不为空

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

'清除匹配结果

With ThisWorkbook.Worksheets("匹配结果") '清除原列表数据

.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 '判断循环时是否匹配成功

With ThisWorkbook.Worksheets("匹配结果") '清除原列表数据

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("匹配结果").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("匹配结果").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("匹配结果").Activate

End Sub

实例36-根据输入值自动填充数据

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

关键词：

为您推荐

快讯
行业
公司