13个sheet 表的数据提取到“全年销售明细”里面，表头都是一样的。其他的不要提取....

lusa

大家好！

详细见附件，就是把202301一直到202312还有上年未收，一共这13个sheet 表的数据提取到“全年销售明细”里面，表头都是一样的。如果后面sheet数据有变化时，全年销售明细里跟着变化，VBA试了好多都实现不了，求助大神

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.11
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("全年销售明细")
   
5.     sh.UsedRange.Clear
   
6.     For Each sht In Sheets
   
7.         If sht.Name = "上年未收" Then fft = 1
   
8.         If Val(sht.Name) > 0 And InStr(sht.Name, "汇率") = 0 Then fft = 1
   
9.         If fft = 1 Then
   
10.             n = n + 1
    
11.             With sht
    
12.                 If n = 1 Then
    
13.                     .UsedRange.Copy sh.[a1]
    
14.                 Else
    
15.                     r = sh.Cells(Rows.Count, 1).End(3).Offset(1).Row
    
16.                     .UsedRange.Offset(1).Copy sh.Cells(r, 1)
    
17.                 End If
    
18.             End With
    
19.         End If
    
20.     Next
    
21.     With sh
    
22.         r = .Cells(Rows.Count, 1).End(3).Row
    
23.         .UsedRange.Offset(r).Clear
    
24.         For i = 2 To r
    
25.             .Cells(i, 1) = i - 1
    
26.         Next
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

lusa

ykcbf1100 发表于 2024-1-11 13:53
附件供参考。。。

感谢感谢，我看看，非常感谢

lusa

ykcbf1100 发表于 2024-1-11 13:53
附件供参考。。。

非常感谢大神，就是我需要的

limonet

关键字：union all

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Sht As Worksheet, Field$
    Field = "F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18,F19,F20,F21,F22,F23,F24,F25,F26,F27,F28"
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If IsNumeric(Sht.Name) Or Sht.Name = "上年未收" Then
            StrSQL = StrSQL & " Union All Select " & Field & " From [" & Sht.Name & "$A2:AB] Where F2<>''"
        End If
    Next Sht
    Sheet3.Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Sht As Worksheet
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If IsNumeric(Sht.Name) Or Sht.Name = "上年未收" Then
            StrSQL = StrSQL & " Union All Select * From [" & Sht.Name & "$A2:AB] Where F2<>''"
        End If
    Next Sht
    Sheet3.Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

lusa

limonet 发表于 2024-1-11 14:23
关键字：union all

非常感谢！很好用

limonet

lusa 发表于 2024-1-11 16:27
非常感谢！很好用

提一句，不推荐字段有重复的，比如备注有2个，202302D列名称没有统一。