参考文献
- WPS Excel通过添加宏实现多张表格合并
用例
- WPS Excel通过添加宏实现多张表格合并
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"
End Sub
- 取出同名学生信息
Sub 导出同名学生()
Dim SH As String
SH = "Sheet4"
Dim SH1 As String
SH1 = "Sheet1"
Sheets(SH).[a1] = "账号"
Sheets(SH).[b1] = "姓名"
Sheets(SH).[c1] = "卡号"
Sheets(SH).[d1] = "卡片类型"
Sheets(SH).[e1] = "身份"
Sheets(SH).[f1] = "卡户押金"
Sheets(SH).[g1] = "钱包号"
Sheets(SH).[h1] = "卡余额"
Sheets(SH).[i1] = "库余额"
Sheets(SH).[j1] = "未圈存金额"
Sheets(SH).[k1] = "未圈存笔数"
a = Sheets(SH1).[a1].CurrentRegion.Rows.Count
For I = 2 To a
k = Sheets(SH).[a1].CurrentRegion.Rows.Count + 1
If Application.WorksheetFunction.CountIf([b1:b65530], Cells(I, 2)) > 1 Then
Sheets(SH).Cells(k, 1) = Sheets(SH1).Cells(I, 1)
Sheets(SH).Cells(k, 2) = Sheets(SH1).Cells(I, 2)
Sheets(SH).Cells(k, 3) = Sheets(SH1).Cells(I, 3)
Sheets(SH).Cells(k, 4) = Sheets(SH1).Cells(I, 4)
Sheets(SH).Cells(k, 5) = Sheets(SH1).Cells(I, 5)
Sheets(SH).Cells(k, 6) = Sheets(SH1).Cells(I, 6)
Sheets(SH).Cells(k, 7) = Sheets(SH1).Cells(I, 7)
Sheets(SH).Cells(k, 8) = Sheets(SH1).Cells(I, 8)
Sheets(SH).Cells(k, 9) = Sheets(SH1).Cells(I, 9)
Sheets(SH).Cells(k, 10) = Sheets(SH1).Cells(I, 10)
Sheets(SH).Cells(k, 11) = Sheets(SH1).Cells(I, 11)
Sheets(SH).Cells(k, 12) = Sheets(SH1).Cells(I, 12)
End If
Next
Sheets(SH).[a1].CurrentRegion.Sort Key1:=Sheets(SH).[b1], Order1:=xlAscending, Header:=xlGuess
If Sheets(SH).[a2] = "" Then
MsgBox ("无同名同姓学生!~")
End If
Sheets(SH).Select
End Sub