同一工作簿下多个表格数据汇总到一个表，且删除重复身份证号码

醉舞冰点

同一工作簿下有不同学生的身份证号码，有多次出现的，要在汇总表中自动汇总身份证号码，且要自动删除重复身份证号

约定的童话

把四个表去重之后汇总到第一个表？

sandays

在PQ中试了一下，很方便。

417744370

试试这个可达到您要的需求不？

1. ub 合并()
   
2.   Dim sht As Worksheet, i As Byte, x%, j%, n% '声明变量
   
3.   Application.ScreenUpdating = False  '关闭屏幕刷新
   
4.     On Error Resume Next  '当程序出错时继续执行下一句
   
5.   Application.DisplayAlerts = False  '关闭提示(删除工作表时会有提示)
   
6.   Worksheets("汇总表").UsedRange.ClearContents  '清空原表的内容
   
7.   For Each sht In Worksheets  '遍历活动工作簿中的所有工作表
   
8.     If sht.Name <> "汇总表" Then  '如果sht的名字不等于“总表”
   
9.       '如果工作表A列有值（忽略空表或者A列无值的工作表）
   
10.       If WorksheetFunction.CountA(sht.Range("A:A")) > 0 Then
    
11.         i = i + 1  '累加变量
    
12.         If i = 1 Then  '如果变量i的值等于1
    
13.           sht.UsedRange.Copy  '复制sht工作表的已用区域
    
14.           Range("a1").PasteSpecial xlPasteAllUsingSourceTheme  '粘贴到活动工作表的A1单元格
    
15.           Range("a1").PasteSpecial xlPasteValues  '再次粘贴，只粘贴值(防止合并前的公式的值不一致)
    
16.           Range("a1").PasteSpecial xlPasteColumnWidths  '再次粘贴，只粘贴列宽
    
17.   x = sht.Cells(Rows.Count, 1).End(xlUp).Row   '目标工作表行总数
    
18.   j = Worksheets("总表").Cells(Rows.Count, 1).End(xlUp).Row ' 活动工作表行总数
    
19.   
    
20. Worksheets("汇总表").Range("I2" & ":" & "I" & x).Value = sht.Name
    
21.         Else
    
22.           sht.UsedRange.Offset(1, 0).Copy  '复制sht工作表的已用区域(排除标题行)
    
23.           With Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)  '引用A列最后一个非空行的下一行
    
24.             .PasteSpecial xlPasteAllUsingSourceTheme  '粘贴
    
25.             .PasteSpecial xlPasteValues  '再次粘贴，只粘贴列宽
    
26.             .PasteSpecial xlPasteColumnWidths  '再次粘贴，只粘贴列宽
    
27.          End With
    
28.   x = sht.Cells(Rows.Count, 1).End(xlUp).Row   '目标工作表行总数
    
29.   j = Worksheets("汇总表").Cells(Rows.Count, 1).End(xlUp).Row  ' 活动工作表行总数
    
30. Worksheets("汇总表").Range("I" & j - x + 2 & ":" & "I" & j).Value = sht.Name  '添加哪个工作中考过行
    
31.       
    
32.         End If
    
33.       End If
    
34.     End If
    
35.   Next sht
    
36.   ActiveSheet.Range("$A$1:$p$" & j).RemoveDuplicates Columns:=1, Header:=xlNo    '去除重复项
    
37.   Application.ScreenUpdating = True  '恢复屏幕刷新
    
38. End Sub
    

复制代码

417744370

试试这个能达到你的需求不

417744370

Sub 合并()
  Dim sht As Worksheet, i As Byte, x%, j%, n% '声明变量
  Application.ScreenUpdating = False  '关闭屏幕刷新
    On Error Resume Next  '当程序出错时继续执行下一句
  Application.DisplayAlerts = False  '关闭提示(删除工作表时会有提示)
  Worksheets("汇总表").UsedRange.ClearContents  '清空原表的内容
  For Each sht In Worksheets  '遍历活动工作簿中的所有工作表
    If sht.Name <> "汇总表" Then  '如果sht的名字不等于“总表”
      '如果工作表A列有值（忽略空表或者A列无值的工作表）
      If WorksheetFunction.CountA(sht.Range("A:A")) > 0 Then
        i = i + 1  '累加变量
        If i = 1 Then  '如果变量i的值等于1
          sht.UsedRange.Copy  '复制sht工作表的已用区域
          Range("a1").PasteSpecial xlPasteAllUsingSourceTheme  '粘贴到活动工作表的A1单元格
          Range("a1").PasteSpecial xlPasteValues  '再次粘贴，只粘贴值(防止合并前的公式的值不一致)
          Range("a1").PasteSpecial xlPasteColumnWidths  '再次粘贴，只粘贴列宽
  x = sht.Cells(Rows.Count, 1).End(xlUp).Row   '目标工作表行总数
  j = Worksheets("总表").Cells(Rows.Count, 1).End(xlUp).Row ' 活动工作表行总数
  
Worksheets("汇总表").Range("I2" & ":" & "I" & x).Value = sht.Name
        Else
          sht.UsedRange.Offset(1, 0).Copy  '复制sht工作表的已用区域(排除标题行)
          With Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)  '引用A列最后一个非空行的下一行
            .PasteSpecial xlPasteAllUsingSourceTheme  '粘贴
            .PasteSpecial xlPasteValues  '再次粘贴，只粘贴列宽
            .PasteSpecial xlPasteColumnWidths  '再次粘贴，只粘贴列宽
         End With
  x = sht.Cells(Rows.Count, 1).End(xlUp).Row   '目标工作表行总数
  j = Worksheets("汇总表").Cells(Rows.Count, 1).End(xlUp).Row  ' 活动工作表行总数
Worksheets("汇总表").Range("I" & j - x + 2 & ":" & "I" & j).Value = sht.Name  '添加哪个工作中考过行
      
        End If
      End If
    End If
  Next sht
  ActiveSheet.Range("$A$1:$p$" & j).RemoveDuplicates Columns:=1, Header:=xlNo    '去除重复项
  Application.ScreenUpdating = True  '恢复屏幕刷新
End Sub

说明：这是在罗老师代码基础上改的

iwangyi

Sub CC()
Set D = CreateObject("SCRIPTING.DICTIONARY")
Set cn = CreateObject("ADODB.CONNECTION")
cn.Open "PROVIDER=MICROSOFT.JET.OLEDB.4.0;EXTENDED PROPERTIES=EXCEL 8.0;DATA SOURCE=" & ThisWorkbook.FullName
For Each SH In Sheets
If SH.Name <> "汇总表" Then
Sql = "SELECT * FROM [" & SH.Name & "$]"
D(Sql) = ""
End If
Next
Sql = Join(D.KEYS, " UNION ALL ")
Sql = "select DISTINCT 身份证号码,姓名 from (" & Sql & ")"
Range("a2").CopyFromRecordset cn.Execute(Sql)
End Sub

iwangyi

附件请参考************

iwangyi

Sub C()
Set D = CreateObject("SCRIPTING.DICTIONARY")
For Each SH In Sheets
If SH.Name <> "汇总表" Then
arr = SH.Range("A1").CurrentRegion
For I = 1 To UBound(arr)
D(arr(I, 1) & vbTab & arr(I, 2)) = ""
Next
End If
Next
[A1].Resize(D.Count) = Application.Transpose(D.KEYS)
[A1].Resize(D.Count).TextToColumns
End Sub

iwangyi

附件请参考**************