Excel VBA取白色单元格内容黄色的单元格的Address

哆哆Excel

发布于 2023-09-09 02:44:49

41400

代码可运行

文章被收录于专栏：哆哆Excel哆哆Excel

运行总次数：0

代码可运行

PS:工作中用到的代码，存起来备用

问题：有一程序：批量提取多工作簿中指定单元格的内容汇总到总表

程序运行如下：

1.取得文件夹中的所有.xlsx文件的路径

2.依次workbooks.Open("文件路径")

3.取得每个工作簿的指定单元格的Address,【此处要先编辑好】

4.再关闭文件

再打开下一个文件，循环下去就可以啦

【问题】问题就在第三步。如下图，数据量大，所以设计一个代码来提高效率

【代码】先用代码取得，再整理一下

代码如下

Sub yhdGet_address()
    Dim outSht As Worksheet
    Dim r As Range, myr As Range
    Dim colorA As Integer, Saddress As String
    Set dicA = CreateObject("scripting.dictionary")
    Set dicB = CreateObject("scripting.dictionary")
    Set outSht = Worksheets("结果")
    With outSht
        colorA = .Range("B2").Interior.ColorIndex
        colorB = .Range("C2").Interior.ColorIndex
    End With
    With Worksheets("测试")
        Set myr = .Range("A1").CurrentRegion
        For Each r In myr
            If r.Interior.ColorIndex = colorA Then dicA(Application.WorksheetFunction.Clean(Replace(r.MergeArea.Cells(1, 1), " ", ""))) = ""
            If r.Interior.ColorIndex = colorB Then dicB(r.MergeArea.Cells(1, 1).Address(0, 0)) = ""
        Next
    End With
    With outSht
        .Range("B3").Resize(dicA.Count, 1) = Application.Transpose(dicA.keys)
        .Range("C3").Resize(dicB.Count, 1) = Application.Transpose(dicB.keys)
    End With
End Sub