表一保存到明细表

徐海洋

请高师指教,几个年级的表,复制粘贴到表一,保存到明细表各年级,求老师赐教,大恩难忘,谢谢!!




班主任统计表.zip (13.52 KB, 下载次数: 4)

2022-6-12 09:57 上传

点击文件名下载附件

hasyh2008

这个仅供参考

hasyh2008

Sub 汇总()
  Dim MyFile As Object
  Dim Arr, ArrName()
  Dim Rc%, K%
  Dim FileName$, Str$
  Dim Wb As Workbook
  Dim Rg As Range
  Set MyFile = CreateObject("scripting.filesystemobject")
  FileName = Dir(ThisWorkbook.Path & "\*.xlsx", 16)
  Do While FileName <> ""
      K = K + 1
      ReDim Preserve ArrName(1 To K)
      ArrName(K) = ThisWorkbook.Path & "\" & FileName
      FileName = Dir
  Loop
  With ThisWorkbook.Sheets("表一")
      .Range("A1").CurrentRegion.Clear
  End With
  For K = 1 To UBound(ArrName)
    Set Wb = Workbooks.Open(ArrName(K))
    With Wb.Sheets(1)
        Rc = .Range("A1").CurrentRegion.Rows.Count
        Str = .Range("A1")
        If K = 1 Then
            .Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("表一").Range("B1")
            With ThisWorkbook.Sheets("表一")
                .Range("A2") = "年级"
                .Range("B1") = ""
                .Range("A3") = Str
                .Range("A3").Resize(Rc - 2, 1).Merge
            End With
        Else
            ThisWorkbook.Sheets("表一").Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(Rc - 2, 1).Merge
            ThisWorkbook.Sheets("表一").Cells(Rows.Count, 1).End(xlUp).Offset(1) = Str
            .Range("A1").CurrentRegion.Offset(2).Copy ThisWorkbook.Sheets("表一").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
        End If
        Wb.Close False
    End With
  Next K
  Set MyFile = Nothing
  Set Wb = Nothing
  Set Rg = Nothing
End Sub

徐海洋

asyh2008 发表于 2022-6-12 15:59
Sub 汇总()
  Dim MyFile As Object
  Dim Arr, ArrName()

老师,表头被合并单元格了不行吗?请恩师赐教,谢谢!!!

您有QQ吗?文件太大,我上传不了附件,

QQ:1336798120

hasyh2008

在我电脑上没问题，和有没有合并无关。

徐海洋

hasyh2008 发表于 2022-6-13 12:05
在我电脑上没问题，和有没有合并无关。

恩师,可以给个QQ联系您吗?附件大,传不上来,以让我记住您的大恩大德,谢谢


恩师,粘贴为数值,怎么修改?

hasyh2008

徐海洋 发表于 2022-6-13 12:17
恩师,可以给个QQ联系您吗?附件大,传不上来,以让我记住您的大恩大德,谢谢

504265918

徐海洋

hasyh2008 发表于 2022-6-13 12:33
504265918

恩师,粘贴为数值,怎么修改?不复制公式

hasyh2008

Option Explicit

Sub 汇总()
  On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
  Application.ScreenUpdating = False '//关闭屏幕刷新
  Application.DisplayAlerts = False '//关闭系统提示
  Application.EnableEvents = False  '//禁止触发其他事件
  Application.StatusBar = False   '关闭系统状态条
  Application.Interactive = False   '禁用鼠标、键盘，防干扰
  Dim Tim
  Tim = Timer
  Dim MyFile As Object
  Dim Arr, ArrName()
  Dim Rc%, Co%, K%
  Dim FileName$, Str$
  Dim Wb As Workbook
  Dim Rg As Range
  Set MyFile = CreateObject("scripting.filesystemobject")
  FileName = Dir(ThisWorkbook.Path & "\*.xlsx", 16)
  Do While FileName <> ""
      K = K + 1
      ReDim Preserve ArrName(1 To K)
      ArrName(K) = ThisWorkbook.Path & "\" & FileName
      FileName = Dir
  Loop
  With ThisWorkbook.Sheets("汇总明细")
      .UsedRange.Clear
  End With
  For K = 1 To UBound(ArrName)
    Set Wb = Workbooks.Open(ArrName(K))
    With Wb.Sheets(1)
        Rc = .Cells(Rows.Count, 1).End(xlUp).Row
        Co = .Cells(3, Columns.Count).End(xlToLeft).Column
        Str = Left(Wb.Name, 3)
        If K = 1 Then
            .Range("A1").Resize(Rc - 5, Co).Copy ThisWorkbook.Sheets("汇总明细").Range("B1")
            ThisWorkbook.Sheets("汇总明细").Range("B1").Resize(Rc - 5, Co).Value = .Range("A1").Resize(Rc - 5, Co).Value
            With ThisWorkbook.Sheets("汇总明细")
                .Range("A2") = "编号"
                .Range("A2:A3").Merge
                .Range("A4") = Str
                .Range("A4").Resize(Rc - 8, 1).Merge
            End With
        Else
            Set Rg = ThisWorkbook.Sheets("汇总明细").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
            Rg.Offset(0, -1).Resize(Rc - 8, 1).Merge
            Rg.Offset(0, -1).Resize(Rc - 8, 1) = Str
            .Range("A4").Resize(Rc - 8, Co).Copy Rg
            Rg.Resize(Rc - 8, Co).Value = .Range("A4").Resize(Rc - 8, Co).Value
            Set Rg = Nothing
        End If
        Wb.Close False
    End With
  Next K
  Set MyFile = Nothing
  Set Wb = Nothing
  
  Application.StatusBar = True   '恢复系统状态条
  Application.EnableEvents = True  '//恢复触发其他事件
  Application.ScreenUpdating = True '//恢复屏幕刷新
  Application.DisplayAlerts = True '//恢复系统提示
  Application.Interactive = True    '启用鼠标键盘
  MsgBox Format(Timer - Tim, "0.00")
End Sub


Sub 清除()
  Sheets("汇总明细").UsedRange.Clear
End Sub

hasyh2008

把三个压缩文件放在同一文件夹中