高手帮助按日期横向合并谢谢

ykcbf1100

xiaodong112233 发表于 2024-6-4 17:16
眼睛肯定是看不过来的。但我可以做统计。

再次修改，可以跨月、跨年合并。

ykcbf1100

更新，可以跨年月合并。

1. Sub ykcbf()  '//2024.6.4   日期作为第一列,日期按顺序排列
   
2.     Dim arr, brr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     ReDim brr(1 To 10000, 1 To 10)
   
6.     bt = [{"代码","收盘"}]
   
7.     Set fso = CreateObject("scripting.filesystemobject")
   
8.     Set Sh = ThisWorkbook.Sheets("合并")
   
9.     p = ThisWorkbook.Path & ""
   
10.     m = 1: n = 1
    
11.     brr(1, 1) = "日期": brr(1, 2) = bt(1): brr(1, 3) = bt(2)
    
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.                 fn = fso.GetBaseName(f)
    
16.                 rq = CDate(Format(Right(fn, 8), "0000-00-00"))
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 With wb.Sheets(1)
    
19.                     arr = .UsedRange
    
20.                 End With
    
21.                 wb.Close SaveChanges:=False
    
22.                 For i = 2 To UBound(arr)
    
23.                     If arr(i, 1) <> Empty Then
    
24.                         m = m + 1
    
25.                         brr(m, 1) = rq
    
26.                         brr(m, 2) = Format(arr(i, 1), "000000")
    
27.                         brr(m, 3) = arr(i, 2)
    
28.                     End If
    
29.                 Next
    
30.             End If
    
31.         End If
    
32.     Next f
    
33.     With Sh
    
34.         .UsedRange.Clear
    
35.         .[a1].Resize(1, 3).Interior.Color = 49407
    
36.         .Columns(2).NumberFormat = "@"
    
37.         With .[a1].Resize(m, 3)
    
38.             .Value = brr
    
39.             .Borders.LineStyle = 1
    
40.             .HorizontalAlignment = xlCenter
    
41.             .VerticalAlignment = xlCenter
    
42.             With .Font
    
43.                 .Name = "微软雅黑"
    
44.                 .Size = 11
    
45.             End With
    
46.         End With
    
47.         Set Rng = .[a2].Resize(m - 1, 3)
    
48.         Rng.Sort .[a2], 1
    
49.         ActiveWindow.DisplayZeros = False
    
50.     End With
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub
    

复制代码