数据提取

baofa2

AAAAA.rar (52.72 KB, 下载次数: 9)

2025-3-25 11:20 上传

点击文件名下载附件

IE_Crayon

供参考

1. Option Explicit
   
2. 
   
3. Sub byz_demo()
   
4. 
   
5.     Dim wb As Workbook, lujing As String
   
6.     Dim F As String, r1 As Range, r2 As Range
   
7.     Dim wb1 As Workbook, ws1 As Worksheet
   
8.     Dim i1, i2, i3
   
9. 
   
10.     Set wb = ActiveWorkbook
    
11.     lujing = wb.Path
    
12.     F = Dir(lujing & "\A (*).xlsx")
    
13.    
    
14.     i1 = 2
    
15.    
    
16.     Do While F <> ""
    
17.    
    
18.         Set wb1 = Workbooks.Open(lujing & "" & F)
    
19.         Set ws1 = wb1.Worksheets("Sheet1")
    
20.         
    
21.         i2 = ws1.Cells(Cells.Rows.Count, "L").End(xlUp).Row + 1
    
22.         i3 = ws1.Cells(Cells.Rows.Count, "O").End(xlUp).Row + 1
    
23.         
    
24.         Set r1 = ws1.Range("L2:L" & i2 - 1): r1.Copy
    
25.         wb.Worksheets("Sheet1").Range("B" & i1 & ":B" & i1 + r1.Rows.Count).PasteSpecial Paste:=xlPasteAll ' 粘贴所有内容和格式
    
26.         Set r2 = ws1.Range("O2:O" & i3 - 1): r2.Copy
    
27.         wb.Worksheets("Sheet1").Range("C" & i1 & ":C" & i1 + r2.Rows.Count).PasteSpecial Paste:=xlPasteAll ' 粘贴所有内容和格式
    
28.         Application.CutCopyMode = False
    
29.         
    
30.         i1 = i1 + Application.WorksheetFunction.Max(r1.Rows.Count, r2.Rows.Count): wb1.Close
    
31.    
    
32.         F = Dir
    
33.         
    
34.     Loop: wb.Save
    
35.    
    
36. End Sub

复制代码

IE_Crayon

代码上传中...

ba3259878266

baofa2 发表于 2025-3-25 11:20

在试  谢谢

ba3259878266

baofa2 发表于 2025-3-25 11:20

谢谢师傅 好用  区域改一下  L4:L7  O4:O7  谢谢你

taller

ba3259878266 发表于 2025-3-25 11:17
版主谢谢 能回附件吗  谢谢

代码已发，审核中

baofa2

ba3259878266 发表于 2025-3-25 11:40
谢谢师傅 好用  区域改一下  L4:L7  O4:O7  谢谢你

ba3259878266

taller 发表于 2025-3-25 11:50
代码已发，审核中

好的   谢谢版主

ykcbf1100

参与一下。。。

ykcbf1100

1. Sub ykcbf()   '//2025.3.15   多文件汇总
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set ws = ThisWorkbook
   
6.     p = ws.Path & ""
   
7.     Set Sh = ws.Sheets("Sheet1")
   
8.     arr = Sh.UsedRange
   
9.     On Error Resume Next
   
10.     Dim tm: tm = Timer
    
11.     ReDim brr(1 To 10 ^ 4, 1 To 100)
    
12.     For Each f In fso.GetFolder(p).Files
    
13.         If LCase$(f.Name) Like "*.xls*" Then
    
14.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
15.                 Set wb = Workbooks.Open(f, 0)
    
16.                 With wb.Sheets(1)
    
17.                     r = .UsedRange.Find("*", , -4163, , 1, 2).Row
    
18.                     c = .UsedRange.Find("*", , -4163, , 2, 2).Column
    
19.                     arr = .[a1].Resize(r, c)
    
20.                 End With
    
21.                 wb.Close 0
    
22.                 For i = 1 To UBound(arr)
    
23.                     If arr(i, 12) <> Empty Then
    
24.                         m = m + 1
    
25.                         brr(m, 1) = arr(i, 12)
    
26.                         brr(m, 2) = arr(i, 15)
    
27.                     End If
    
28.                 Next
    
29.             End If
    
30.         End If
    
31.     Next f
    
32.     With Sh
    
33.         .UsedRange = Empty
    
34.         .[a1].Resize(m, 2) = brr
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
38. End Sub
    

复制代码