工作中，按区域收集得数据需要提取共同得列到一张表，每个区域各列并不相同。
目标- 条件表
- 结果表
- 近日表
1个文件内12个表页
每个表页内清单区域得主要表头
代码Private Sub CommandButton1_Click() Dim start As Double start = Timer '设置计时器 Dim myfile, mypath, wb '声明变量 Application.ScreenUpdating = False '关闭屏幕更新 'Sheet1.UsedRange.Offset(1, 0).Clear '清除除表头之外得所有内容 Sheets("结果表").UsedRange.Clearc1 = Sheets("条件表").Range("B5").CurrentRegion.Columns.Count - 1 'b5单元格CTRL+A得区域得列数-1 R1 = Sheets("条件表").Range("B5").CurrentRegion.Rows.Count - 1 'b5单元格CTRL+A得区域得行数-1 Sheets("条件表").Range("C9").Resize(1, c1).Copy '选择粘贴成值 Sheets("结果表").Range("A1").PasteSpecial Paste:=xlPastevalues mypath = ThisWorkbook.Path myfile = Dir(mypath & "\*.xls*") Do While myfile <> "" If myfile <> ThisWorkbook.Name Then Set wb = GetObject(mypath & "\" & myfile) '统计要合并得工作表得数量（循环次数） N1 = Sheets("条件表").Range("C2") '近日表开始序号 For I = N1 To Sheets("条件表").Range("C3") '若表数量不确定用wb.Sheets.Count wb.Sheets(I).UsedRange.UnMerge Set Rng = Sheets("结果表").Range("B65536").End(xlUp).Offset(1, 0) '获得结果表A列第壹个空单元格 For j = 1 To c1 '近日表先按列循环 For k = 1 To R1 '近日表先按行循环 ce1 = Sheets("条件表").Range("B5").Offset(k, j).Value If ce1 = "" Then Exit For Else 'CE1为空值时，跳出当前循环 C2 = wb.Sheets(I).UsedRange.Find(ce1, , , xlWhole).Column On Error Resume Next '报错跳过 N2 = 2 '近日表中得有值得列序号 XROW = wb.Sheets(I).Range("A1").Offset(ce2, N2).CurrentRegion.Rows.Count - 1 '获得近日表中得记录条数 ce2 = Sheets("条件表").Range("B5").Offset(k, 0).Value '近日表中表头得行序号 wb.Sheets(I).Range("A1").Offset(ce2, C2 - 1).Resize(XROW, 1).Copy '选择粘贴成值 Rng.Range("A1").Offset(0, j - 1 + k - 2).PasteSpecial Paste:=xlPastevalues Next k Next j Next I '主体程序执行完毕 wb.Close False End If myfile = Dir Loop Application.ScreenUpdating = True MsgBox "运行程序使用" & Format(Timer - start, "0.00") & "秒" End Sub
