|
|
Private Sub CommandButton1_Click()
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("原始")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(4, Columns.Count).End(xlToLeft).Column
If r < 2 Or y < 2 Then MsgBox "原始表为空，请先导入数据！": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
d(.List(i, 0)) = ""
m = m + 1
End If
Next i
End With
With ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
k = k + 1
dc(.List(i, 0)) = ""
End If
Next i
End With
ReDim br(1 To m + 1, 1 To k + 1)
n = 1
br(1, 1) = "姓名"
For i = 2 To UBound(ar, 1)
t = 1
If d.exists(ar(i, 1)) Then
n = n + 1
br(n, 1) = ar(i, 1)
For j = 1 To UBound(ar, 2)
If dc.exists(ar(1, j)) Then
t = t + 1
br(1, t) = ar(1, j)
br(n, t) = ar(i, j)
End If
Next j
End If
Next i
With Sheets("实现效果")
.UsedRange = Empty
.[a1].Resize(UBound(br), UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub
Private Sub UserForm_Initialize()
With Sheets("原始")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(4, Columns.Count).End(xlToLeft).Column
If r < 2 Or y < 2 Then MsgBox "原始表为空，请先导入数据！": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
With ListBox1
.Clear
.List = ar
End With
With ListBox2
.Clear
.List = Application.Transpose(ar)
End With
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-17 12:22
