楼主
liuguansky |
Q:如何弹出窗体选择、空行分隔合并、记录去重工作表记录？
有多个工作表，只需要提取选定的工作表中的几项不重复内容，合成一个新表格。表格内容间以空行间隔。
A：用如下窗体代码：
- Private Sub CommandButton1_Click()
- Dim str1$, i&, arrt(), k&
- If ListBox1.ListCount >= 1 Then
- For i = 0 To ListBox1.ListCount - 1
- If ListBox1.Selected(i) = True Then
- k = k + 1: ReDim Preserve arrt(1 To 2, 1 To k)
- arrt(1, k) = i: arrt(2, k) = ListBox1.List(i)
- End If
- Next i
- For i = 1 To k
- ListBox1.RemoveItem arrt(1, i) + 1 - i
- ListBox2.AddItem arrt(2, i)
- Next
- End If
- End Sub
- Private Sub CommandButton2_Click()
- Dim str1$, i&, arrt(), k&
- If ListBox2.ListCount >= 1 Then
- For i = 0 To ListBox2.ListCount - 1
- If ListBox2.Selected(i) = True Then
- k = k + 1: ReDim Preserve arrt(1 To 2, 1 To k)
- arrt(1, k) = i: arrt(2, k) = ListBox2.List(i)
- End If
- Next i
- For i = 1 To k
- ListBox2.RemoveItem arrt(1, i) + 1 - i
- ListBox1.AddItem arrt(2, i)
- Next
- End If
- End Sub
- Private Sub CommandButton3_Click()
- Dim i&, arr, d, k&, j&, col&, dd, temp&, str1$
- Set d = CreateObject("scripting.dictionary")
- UserForm1.Hide
- On Error Resume Next
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- If ListBox2.ListCount >= 1 Then
- Sheets("结果").Delete
- Sheets.Add after:=Sheets(Sheets.Count)
- With ActiveSheet
- .Name = "结果"
- .Cells(1, 1).Resize(1, 4) = Array("宗地号", "点号", "x", "y")
- col = 1
- For i = 0 To ListBox2.ListCount - 1
- str1 = ListBox2.List(i)
- With Sheets(str1)
- k = .Cells(.Rows.Count, 2).End(3).Row - 9
- arr = .Cells(10, 2).Resize(k, 3).Value
- For j = 1 To k Step 2
- If arr(j, 1) <> "" Then
- If Not d.exists(arr(j, 1)) Then
- d.Add arr(j, 1), Application.Index(arr, j, 0)
- End If
- End If
- Next j
- End With
- temp = col
- For Each dd In d.keys
- col = col + 1
- .Cells(col, 2).Resize(1, 3) = d(dd)
- If col = temp + 1 Then .Cells(col, 1) = "'" & str1
- Next
- col = col + 1
- Next
- End With
- Else: MsgBox "未选择表，请选择。": UserForm1.Show
- End If
- Unload UserForm1
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- Set d = Nothing
- End Sub
- Private Sub CommandButton4_Click()
- Call justsoso
- End Sub
- Private Sub UserForm_Initialize()
- UserForm1.Caption = "请选择要汇总的工作表表名："
- Call justsoso
- End Sub
- Sub justsoso()
- Dim i%, st
- ListBox1.Clear
- ListBox2.Clear
- ListBox1.MultiSelect = fmMultiSelectExtended
- ListBox2.MultiSelect = fmMultiSelectExtended
- For i = 1 To Sheets.Count
- st = Sheets(i).Name
- If VBA.IsNumeric(str1) And Len(CStr(st)) = 10 Then
- ListBox1.AddItem Sheets(i).Name
- End If
- Next i
- End Sub
|