常用代码归集

自由的游

mark一下以后一点一点研究

jsgj2023

http://club.excelhome.net/thread-1374458-1-1.html
如何实现跨多个表的vlookup查询
Sub Adele()
    Dim d  As Object, sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    On Error Resume Next
    For Each sht In Worksheets
        If sht.Name <> "TEST1" Then
            With sht
                arr = .Range("a1").CurrentRegion
                For x = 2 To UBound(arr)
                    s = sht.Name & "," & arr(x, 1)
                    d(s) = Array(arr(x, 2), arr(x, 3), arr(x, 4), arr(x, 5), arr(x, 6), arr(x, 7), arr(x, 8), arr(x, 9), arr(x, 10), arr(x, 11), arr(x, 12))
                Next
            End With
        End If
    Next
    With Sheets("TEST1")
        .Range("e2:q65535").ClearContents
        brr = .Range("a1").CurrentRegion
        For y = 2 To UBound(brr)
            sbr = brr(y, 1) & "," & brr(y, 2)
            If d.exists(sbr) Then
                .Cells(y, 5).Resize(1, 11) = d(sbr)
            End If
        Next
    End With
End Sub

jsgj2023

'请帮忙使用宏编程随机提取相应清单内容
http://club.excelhome.net/thread-1374820-1-1.html
Sub Adele()
    Dim d  As Object, arr, r&, nNum&, z&
    Dim sCity$, brr(), crr(1 To 10), drr(), er(1 To 10, 1 To 11)
    arr = Range("a1").CurrentRegion
    nNum = InputBox("输入数量", "温馨提示")
    sCity = InputBox("输入地市名称", "温馨提示")
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For x = 3 To UBound(arr)
            If arr(x, 11) = "呼入" Then
                k = k + 1
                For y = 1 To UBound(arr, 2): brr(k, y) = arr(x, y): Next
            End If
    Next
    ReDim drr(1 To UBound(brr), 1 To UBound(brr, 2))
    For m = 1 To UBound(brr)
        If InStr(brr(m, 10), sCity) Then
            kk = kk + 1
            For n = 1 To UBound(brr, 2): drr(kk, n) = brr(m, n): Next
        End If
    Next
    For a = 1 To nNum: crr(a) = Int(Rnd * kk): Next
    For z = 1 To UBound(drr)
        For c = 1 To UBound(crr)
            If z = crr(c) Then
                k1 = k1 + 1
                For l = 1 To UBound(drr, 2)
                    er(k1, l) = drr(z, l)
                Next
            End If
        Next
    Next
    Columns("p:ac").NumberFormatLocal = "@"
    [t1].Resize(UBound(er), UBound(er)) = er
End Sub

songsirg

楼主辛苦，收藏了慢慢研究学习

mozhile

插一足，备查备用，谢谢

feilanga

期待表格汇总，搜索对应代码

jsgj2023

20171022
http://club.excelhome.net/thread-1375080-1-1.html
求多条件复杂判断VBA解决方案
Sub Adele()
    With Sheets("Sheet1")
        arr = .Range("a1").CurrentRegion
        For x = 2 To UBound(arr)
            If arr(x, 4) > 30 Then
                If arr(x, 1) = "db111" Or arr(x, 1) = "db411" And arr(x, 3) > 25 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db211" And arr(x, 3) > 5 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db311" And arr(x, 3) > 0.5 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db511" And arr(x, 3) > 30 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db611" And arr(x, 3) > 15 Then
                    arr(x, 5) = "合格"
                Else
                    arr(x, 5) = "不合格"
                End If
            Else
                If arr(x, 1) = "db111" Or arr(x, 1) = "db411" And arr(x, 3) > 400 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db211" And arr(x, 3) > 40 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db311" And arr(x, 3) > 30 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db511" And arr(x, 3) > 500 Then
                    arr(x, 5) = "合格"
                ElseIf arr(x, 1) = "db611" And arr(x, 3) > 100 Then
                    arr(x, 5) = "合格"
                Else
                    arr(x, 5) = "不合格"
                End If
            End If
        Next
        .[e1].Resize(UBound(arr)) = Application.Index(arr, , 5)
    End With
End Sub

jsgj2023

20171022
http://club.excelhome.net/thread-1375159-1-1.html
关于vba汇总问题
Sub Adele()
    Dim Arr, brr(1 To 5000, 1 To 5)
    Application.ScreenUpdating = False
    Sheet5.Activate
    Cells.UnMerge
    Cells.ClearContents
    For Each sh In Worksheets
        If sh.Name <> "汇总表" And sh.Name <> "汇总后的效果" Then
            With sh
                Arr = .Range("a1").CurrentRegion
                For x = 3 To UBound(Arr)
                    k = k + 1
                    For y = 1 To UBound(Arr, 2)
                        brr(k, 1) = sh.Name
                        brr(k, y + 1) = Arr(x, y)
                    Next y
                Next x
            End With
        End If
    Next sh
    Range("a1") = "产品成果表"
    Range("a1").Resize(1, 5).Merge
    Range("a2").Resize(1, 5) = [{"表名","编号","姓名","目标","完成"}]
    Sheets("汇总表").Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
    Range("a2:e" & k + 2).Borders.LineStyle = xlContinuous
    Application.DisplayAlerts = False
    For i = 3 To [a65536].End(3).Row
        For x = i + 1 To [a65536].End(3).Row
            If Cells(x, 1) = Cells(i, 1) Then Range(Cells(i, 1), Cells(x, 1)).Merge
        Next
    Next
    Cells.HorizontalAlignment = xlCenter
    Cells.VerticalAlignment = xlCenter
    Application.ScreenUpdating = True
End Sub

jsgj2023

怎么在A列查找数据并跳到该数据所在位置
http://club.excelhome.net/thread-1375510-1-1.html
Sub Adele()
    Dim d  As Object, s$, arr, x&
    s = InputBox("请输入查找数据", "温馨提示")
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .Range("a1").CurrentRegion
        For x = 1 To UBound(arr)
            d(arr(x, 1)) = x
        Next
        If d.exists(s) Then .Cells(d(s), 1).Select Else MsgBox "您输入的数据不存在,请添加!"
    End With
End Sub

jsgj2023

根据D列提取到相关的工作表
http://club.excelhome.net/thread-1375626-1-1.html
Sub Adele()
    Dim d, arr, x&, L&, sh As Worksheet, r&, y&, z&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For y = Sheets.Count To 2 Step -1
        Sheets(y).Delete
    Next y
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set sh = Sheets("10月份木纹机台产量")
    sh.Select
    Set d = CreateObject("Scripting.dictionary")
    Application.ScreenUpdating = False
    arr = Range("a1").CurrentRegion
    brr = Array("1#", "2#", "3#", "4#", "5#", "6#")
    For z = 0 To UBound(brr)
        a = "木纹" & brr(z) & "机"
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = brr(z)
        sh.Select
        If Application.Version = 14 Then
            Range("A1").CurrentRegion.AutoFilter 4, "=" & a
        Else
            Range("A1").CurrentRegion.AutoFilter 4, a
        End If
        Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
        With Sheets(Sheets.Count)
            .Range("A1").PasteSpecial xlPasteAll
            .Cells.EntireColumn.AutoFit
        End With
        Range("A5").CurrentRegion.AutoFilter
    Next z
Application.ScreenUpdating = True
End Sub