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

LIUZHU

JSA代码，供参考，不知道对不对，我看到别人写了一堆代码

1. function 合并(){
   
2.         let arr=[];
   
3.         let fname=Dir(`${ThisWorkbook.Path}\\*.xls*`,8);
   
4.         while(fname!=""){
   
5.                 if (fname!=ThisWorkbook.Name) arr.push(fname);
   
6.                 fname=Dir();
   
7.         }
   
8.         arr.sort((a,b)=>a.slice(-7).slice(0,2).localeCompare(b.slice(-7).slice(0,2)));                //文件名后两位排序
   
9.         arr.forEach(x=>{
   
10.                 let wb=Workbooks.Open(`${ThisWorkbook.Path}\\${x}`);
    
11.                 let res=Range("a1").CurrentRegion.Value2;
    
12.                 wb.Close(false);
    
13.                 let rng=Cells.Item(1,Columns.Count).End(xlToLeft);
    
14.                 if (rng.Column!=1) rng=rng.Offset(0,1);
    
15.                 rng.Resize(res.length,res[0].length).Value2=res;
    
16.         });
    
17. }

复制代码

LIUZHU

WPS软件打开查看效果，运行JS宏

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strPath$, iRowSize&, iColSize&
    Dim ar, br(), i&, j&, r&, n&, k&
   
    Application.ScreenUpdating = False
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsx")
    Do Until strFileName = ""
        With GetObject(strPath & strFileName)
            r = r + 1
            ReDim Preserve br(1 To r)
            br(r) = .Sheets(1).[A1].CurrentRegion.Value
            If UBound(br(r)) > iRowSize Then iRowSize = UBound(br(r))
            iColSize = iColSize + UBound(br(r), 2)
            .Close False
        End With
        strFileName = Dir
    Loop
   
    ReDim ar(1 To iRowSize, 1 To iColSize) As String
    For j = 1 To UBound(br)
        If j = 1 Then n = 0 Else n = n + UBound(br(j), 2)
        For i = 1 To UBound(br(j))
            For k = 1 To UBound(br(j), 2)
                ar(i, n + k) = br(j)(i, k)
            Next k
        Next i
    Next j
   
    [A1].CurrentRegion.Clear
    [A1].Resize(UBound(ar), UBound(ar, 2)) = ar
   
    Application.ScreenUpdating = True
    Beep
End Sub

xiaodong112233

好的 多谢多谢

gwjkkkkk

参与一下。。。

ykcbf1100

再次更新，确保日期按顺序排列

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 100)
   
6.     bt = [{"代码","收盘"}]
   
7.     Set fso = CreateObject("scripting.filesystemobject")
   
8.     Set Sh = ThisWorkbook.Sheets("合并")
   
9.     p = ThisWorkbook.Path & ""
   
10.     For x = 1 To 31
    
11.         For Each f In fso.GetFolder(p).Files
    
12.             If LCase$(f.Name) Like "*.xls*" Then
    
13.                 If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
14.                     fn = fso.GetBaseName(f)
    
15.                     If x = Val(Right(fn, 2)) Then
    
16.                         n = n + 2
    
17.                         m = 2
    
18.                         rq = x
    
19.                         Set wb = Workbooks.Open(f, 0)
    
20.                         With wb.Sheets(1)
    
21.                             arr = .UsedRange
    
22.                             wb.Close False
    
23.                         End With
    
24.                         brr(1, n - 1) = x & "日"
    
25.                         brr(2, n - 1) = bt(1)
    
26.                         brr(2, n) = bt(2)
    
27.                         For i = 2 To UBound(arr)
    
28.                             If arr(i, 1) <> Empty Then
    
29.                                 m = m + 1
    
30.                                 brr(m, n - 1) = Format(arr(i, 1), "000000")
    
31.                                 brr(m, n) = arr(i, 2)
    
32.                             End If
    
33.                         Next
    
34.                         Max = IIf(Max < m, m, Max)
    
35.                         Exit For
    
36.                     End If
    
37.                 End If
    
38.             End If
    
39.         Next f
    
40.     Next
    
41.     With Sh
    
42.         .UsedRange.Clear
    
43.         .[a1].Resize(2, n).Interior.Color = 49407
    
44.         For col = 1 To n Step 2
    
45.             Columns(col).NumberFormat = "@"
    
46.         Next col
    
47.         With .[a1].Resize(Max, n)
    
48.             .Value = brr
    
49.             .Borders.LineStyle = 1
    
50.             .HorizontalAlignment = xlCenter
    
51.             .VerticalAlignment = xlCenter
    
52.             With .Font
    
53.                 .Name = "微软雅黑"
    
54.                 .Size = 11
    
55.             End With
    
56.         End With
    
57.         For col = 1 To n Step 2
    
58.             .Cells(1, col).Resize(, 2).Merge
    
59.         Next col
    
60.         ActiveWindow.DisplayZeros = False
    
61.     End With
    
62.     Application.ScreenUpdating = True
    
63.     MsgBox "OK！"
    
64. End Sub
    

复制代码

xiaodong112233

ykcbf1100 发表于 2024-6-4 09:15
再次更新。

高手 可以帮我改一下吗？这个公式好像只有一个月的。
我想改成多个月的合并在一起。这个可以吗？

ykcbf1100

xiaodong112233 发表于 2024-6-4 16:44
高手 可以帮我改一下吗？这个公式好像只有一个月的。
我想改成多个月的合并在一起。这个可以吗？

你还是一个月一个月的搞吧，一个月已经有62列了，多个月的话，你看得过来吗？！

xiaodong112233

眼睛肯定是看不过来的。但我可以做统计。