求助，如何用VBA按条件获取数据

八九不离十

VBA按条件提取数据

LIUZHU

提取的效果

LIUZHU

JSA代码，刚好适合WPS软件

1. function 汇总(){
   
2.         const year=Sheets.Item("汇总").Range("h1").Value2
   
3.         let res=["A","B","C","F"].reduce((res,name)=>{
   
4.                 let [bm,sc]=Sheets.Item(name).Range("b1:c1").Value2[0];
   
5.                 let arr=Sheets.Item(name).Range("a1").CurrentRegion.Value2;
   
6.                 return arr.slice(2).forEach(([a,b,c])=>a==year?res.push([bm,sc,a,b,c]):null), res;
   
7.         },[["编码","市场","年份","月份","数量"]])
   
8.         Range("a1").Resize(res.length, res[0].length).Value2=res;
   
9. }

复制代码

LIUZHU

附件，请参考

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, wks As Worksheet, strFind$
   
    Application.ScreenUpdating = False
   
    With [A1].CurrentRegion
        .Offset(1).Clear
        ar = .Resize(10 ^ 4).Value
        r = 1
    End With
   
    strFind = [H1].Value
    For Each wks In Worksheets
        If InStr(",A,B,C,F,", "," & wks.Name & ",") Then
             br = wks.[A1].CurrentRegion.Value
             For i = 3 To UBound(br)
                 If br(i, 1) = strFind Then
                 r = r + 1
                 ar(r, 1) = br(1, 2)
                 ar(r, 2) = br(1, 3)
                 For j = 1 To UBound(br, 2)
                     ar(r, j + 2) = br(i, j)
                 Next j
                 End If
             Next i
         End If
    Next
        
    [A1].Resize(r, UBound(ar, 2)) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

.............

limonet

关键字：LIKE

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;Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name Like "[A-F]" Then
            StrSQL = StrSQL & " Union All Select *,'" & Sht.Range("B1") & "','" & Sht.Range("C1") & "' From [" & Sht.Name & "$A2:C" & Sht.Range("A2").End(xlDown).Row & "] Where 年份=" & [H1]
        End If
    Next Sht
    Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

wang-way

limonet 发表于 2024-6-6 18:29
关键字：LIKE

我猜楼主后期是要修改 ABCF  这种工作表名

limonet

wang-way 发表于 2024-6-6 18:33
我猜楼主后期是要修改 ABCF  这种工作表名

你可能猜对了，谁知道呢。