Excel循环从单元格中提取信息_Excel_Excel Formula_Vba

Excel循环从单元格中提取信息

excel excel-formula vba

Excel循环从单元格中提取信息,excel,excel-formula,vba,Excel,Excel Formula,Vba,我有这个表1，并试图实现表2的结果当前数据： | A | 150112 Charlston.jpg 281320: (143,124,113) #8F7C71 srgb(143,124,113) 1408099: (178,161,151) #B2A197 srgb(178,161,151) 1685636: (200,183,173) #C8B7AD srgb(200,183,173)

我有这个表1，并试图实现表2的结果

当前数据：

|                 A                            | 
150112 Charlston.jpg    
281320: (143,124,113) #8F7C71 srgb(143,124,113) 
1408099: (178,161,151) #B2A197 srgb(178,161,151)    
1685636: (200,183,173) #C8B7AD srgb(200,183,173)    

218600.jpg  
4385653: ( 29, 23, 29) #1D171D srgb(29,23,29)   
2192865: ( 76, 47, 69) #4C2F45 srgb(76,47,69)   
1409815: ( 96, 84,100) #605464 srgb(96,84,100)  

218622.jpg  
1519955: ( 30, 56, 57) #1E3839 srgb(30,56,57)   
1551616: ( 33, 62, 65) #213E41 srgb(33,62,65)   
2118603: ( 34, 58, 59) #223A3B srgb(34,58,59)

预期成果：

|          E         |  F | G | H |

                        R   G   B
150112 Charlston.jpg    143 124 113
150112 Charlston.jpg    178 161 151
150112 Charlston.jpg    200 183 173
218600.jpg              29  23  29
218600.jpg              76  57  69
218600.jpg              96  84  100
218622.jpg              30  56  57
218622.jpg              33  62  65
218622.jpg              34  58  59

我需要的帮助是循环查找A列和x+5行，并为每个唯一的jpg名称向下复制到D列3次。

至于RGB列，我找到了从单元格中提取信息的公式

对于R

对于G

为了B

有没有办法把这个添加到循环代码中，这样它就不会从空白和.jpg单元格中出错？

谢谢

B返回124113是有意义的，因为您从第一个逗号到第一个结束括号都取了一个子字符串。以下解决方案很混乱，但它可以工作：

=MID(MID($A2,FIND(",",$A2)+1,LEN(A2)-FIND(",",$A2)),FIND(",",MID($A2,FIND(",",$A2)+1,LEN(A2)-FIND(",",$A2)))+1,FIND(")",MID($A2,FIND(",",$A2)+1,LEN(A2)-FIND(",",$A2)))-FIND(",",MID($A2,FIND(",",$A2)+1,LEN(A2)-FIND(",",$A2)))-1)

上述内容实际上用一个子字符串替换了A2引用，该子字符串排除了第一个逗号之前的所有内容。如果将函数拆分为两个单独的单元，则更干净、更容易理解

例如，列X可以包含以下公式：

=MID($A2,FIND(",",$A2)+1,LEN(A2)-FIND(",",$A2))

然后B变成：

=MID(X2,FIND(",",X2)+1,FIND(")",X2)-FIND(",",X2)-1)

还请注意，您的G假设它与R具有相同的长度。

因为您的标记中有VBA，所以这里有一个VBA解决方案

请在代码注释中注意，您必须设置某些引用，并将类模块重命名为
cRGB

在常规模块中，您可以通过更改模块开头附近的

wsRes

和

rRes

（工作表和结果范围的左上角单元格），将输出放在任意位置

它输出的正是上面显示的内容

代码使用正则表达式来提取组件
它在数据中循环并在找到.jpg条目时启动一个新的类对象
每个对象都由.jpg条目和相关RGB值的集合（字典）组成
类对象收集在字典中

上述方法使得创建输出更加简单，并且易于修改，以满足将来的需要

课程模块

'Rename this module: cRGB

Option Explicit

Private pJPG As String
Private pR As Long
Private pG As Long
Private pB As Long
Private pRGB As String
Private pRGBs As Dictionary

Private Sub Class_Initialize()
    Set pRGBs = New Dictionary
End Sub

Public Property Get JPG() As String
    JPG = pJPG
End Property
Public Property Let JPG(Value As String)
    pJPG = Value
End Property

Public Property Get R() As Long
    R = pR
End Property
Public Property Let R(Value As Long)
    pR = Value
End Property

Public Property Get G() As Long
    G = pG
End Property
Public Property Let G(Value As Long)
    pG = Value
End Property

Public Property Get B() As Long
    B = pB
End Property
Public Property Let B(Value As Long)
    pB = Value
End Property

Public Property Get RGB() As String
    RGB = pRGB
End Property
Public Property Let RGB(Value As String)
    pRGB = Value
End Property

Public Property Get RGBs() As Dictionary
    Set RGBs = pRGBs
End Property
Public Function addRGBsItem()
  Dim V(2) As Variant
        V(0) = Me.R
        V(1) = Me.G
        V(2) = Me.B
        RGBs.Add Join(V, ","), V
End Function

'Set References to
'   Microsoft Scripting Runtime
'   Microsoft VBScript Regular Expressions 5.5
Option Explicit

Sub getRGB()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dR As Dictionary, cR As cRGB
    Dim RE As RegExp, MC As MatchCollection, M As Match
    Const spatJPG As String = "^.*\.jpg\s*$"
    Const spatRGB As String = "\((\d+),(\d+),(\d+)\)\s*$"
    Dim S As String, V As Variant, W As Variant, I As Long

'Set source and results worksheets
'   results range
'   Read source into vba array
Set wsSrc = Worksheets("Sheet")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'Initialize dictionary
Set dR = New Dictionary
    dR.CompareMode = TextCompare

'Initialize Regex
Set RE = New RegExp
With RE
    .IgnoreCase = True
    .MultiLine = True

'cycle through the source data
    For Each V In vSrc
        If Not V = "" Then
            .Pattern = spatJPG
            If .Test(V) = True Then
                S = V
                Set cR = New cRGB
                    cR.JPG = S
                    dR.Add Key:=S, Item:=cR
            Else
                .Pattern = spatRGB
                If .Test(V) = True Then
                    Set MC = .Execute(V)
                        With MC(0)
                            dR(S).R = .SubMatches(0)
                            dR(S).G = .SubMatches(1)
                            dR(S).B = .SubMatches(2)
                        End With
                        dR(S).addRGBsItem
                End If
            End If
        End If
    Next V
End With

'size results array
I = 0
For Each V In dR.Keys
    I = I + dR(V).RGBs.Count
Next V

ReDim vRes(0 To I, 1 To 4)

'Header Row
vRes(0, 1) = ""
vRes(0, 2) = "R"
vRes(0, 3) = "G"
vRes(0, 4) = "B"

'Populate the data
I = 0
For Each V In dR.Keys
    For Each W In dR(V).RGBs.Keys
        I = I + 1
        vRes(I, 1) = dR(V).JPG
        vRes(I, 2) = Split(W, ",")(0)
        vRes(I, 3) = Split(W, ",")(1)
        vRes(I, 4) = Split(W, ",")(2)
    Next W
Next V

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

常规模块

'Rename this module: cRGB

Option Explicit

Private pJPG As String
Private pR As Long
Private pG As Long
Private pB As Long
Private pRGB As String
Private pRGBs As Dictionary

Private Sub Class_Initialize()
    Set pRGBs = New Dictionary
End Sub

Public Property Get JPG() As String
    JPG = pJPG
End Property
Public Property Let JPG(Value As String)
    pJPG = Value
End Property

Public Property Get R() As Long
    R = pR
End Property
Public Property Let R(Value As Long)
    pR = Value
End Property

Public Property Get G() As Long
    G = pG
End Property
Public Property Let G(Value As Long)
    pG = Value
End Property

Public Property Get B() As Long
    B = pB
End Property
Public Property Let B(Value As Long)
    pB = Value
End Property

Public Property Get RGB() As String
    RGB = pRGB
End Property
Public Property Let RGB(Value As String)
    pRGB = Value
End Property

Public Property Get RGBs() As Dictionary
    Set RGBs = pRGBs
End Property
Public Function addRGBsItem()
  Dim V(2) As Variant
        V(0) = Me.R
        V(1) = Me.G
        V(2) = Me.B
        RGBs.Add Join(V, ","), V
End Function

'Set References to
'   Microsoft Scripting Runtime
'   Microsoft VBScript Regular Expressions 5.5
Option Explicit

Sub getRGB()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dR As Dictionary, cR As cRGB
    Dim RE As RegExp, MC As MatchCollection, M As Match
    Const spatJPG As String = "^.*\.jpg\s*$"
    Const spatRGB As String = "\((\d+),(\d+),(\d+)\)\s*$"
    Dim S As String, V As Variant, W As Variant, I As Long

'Set source and results worksheets
'   results range
'   Read source into vba array
Set wsSrc = Worksheets("Sheet")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'Initialize dictionary
Set dR = New Dictionary
    dR.CompareMode = TextCompare

'Initialize Regex
Set RE = New RegExp
With RE
    .IgnoreCase = True
    .MultiLine = True

'cycle through the source data
    For Each V In vSrc
        If Not V = "" Then
            .Pattern = spatJPG
            If .Test(V) = True Then
                S = V
                Set cR = New cRGB
                    cR.JPG = S
                    dR.Add Key:=S, Item:=cR
            Else
                .Pattern = spatRGB
                If .Test(V) = True Then
                    Set MC = .Execute(V)
                        With MC(0)
                            dR(S).R = .SubMatches(0)
                            dR(S).G = .SubMatches(1)
                            dR(S).B = .SubMatches(2)
                        End With
                        dR(S).addRGBsItem
                End If
            End If
        End If
    Next V
End With

'size results array
I = 0
For Each V In dR.Keys
    I = I + dR(V).RGBs.Count
Next V

ReDim vRes(0 To I, 1 To 4)

'Header Row
vRes(0, 1) = ""
vRes(0, 2) = "R"
vRes(0, 3) = "G"
vRes(0, 4) = "B"

'Populate the data
I = 0
For Each V In dR.Keys
    For Each W In dR(V).RGBs.Keys
        I = I + 1
        vRes(I, 1) = dR(V).JPG
        vRes(I, 2) = Split(W, ",")(0)
        vRes(I, 3) = Split(W, ",")(1)
        vRes(I, 4) = Split(W, ",")(2)
    Next W
Next V

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

您的屏幕截图无法轻松转换为工作表数据。请提供文本、工作簿链接或方法，以便于我们帮助您。将数据从屏幕输入到工作表是非常繁琐的。还有，Excel的哪个版本？我编辑了格式，以便更容易复制和粘贴数据。我正在使用excel 2013。谢谢谢谢容易多了。啊，我在看到你的评论之前就找到了答案。谢谢现在，我只需要帮助将.jpg单元格填充到列E中

'Set References to
'   Microsoft Scripting Runtime
'   Microsoft VBScript Regular Expressions 5.5
Option Explicit

Sub getRGB()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dR As Dictionary, cR As cRGB
    Dim RE As RegExp, MC As MatchCollection, M As Match
    Const spatJPG As String = "^.*\.jpg\s*$"
    Const spatRGB As String = "\((\d+),(\d+),(\d+)\)\s*$"
    Dim S As String, V As Variant, W As Variant, I As Long

'Set source and results worksheets
'   results range
'   Read source into vba array
Set wsSrc = Worksheets("Sheet")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'Initialize dictionary
Set dR = New Dictionary
    dR.CompareMode = TextCompare

'Initialize Regex
Set RE = New RegExp
With RE
    .IgnoreCase = True
    .MultiLine = True

'cycle through the source data
    For Each V In vSrc
        If Not V = "" Then
            .Pattern = spatJPG
            If .Test(V) = True Then
                S = V
                Set cR = New cRGB
                    cR.JPG = S
                    dR.Add Key:=S, Item:=cR
            Else
                .Pattern = spatRGB
                If .Test(V) = True Then
                    Set MC = .Execute(V)
                        With MC(0)
                            dR(S).R = .SubMatches(0)
                            dR(S).G = .SubMatches(1)
                            dR(S).B = .SubMatches(2)
                        End With
                        dR(S).addRGBsItem
                End If
            End If
        End If
    Next V
End With

'size results array
I = 0
For Each V In dR.Keys
    I = I + dR(V).RGBs.Count
Next V

ReDim vRes(0 To I, 1 To 4)

'Header Row
vRes(0, 1) = ""
vRes(0, 2) = "R"
vRes(0, 3) = "G"
vRes(0, 4) = "B"

'Populate the data
I = 0
For Each V In dR.Keys
    For Each W In dR(V).RGBs.Keys
        I = I + 1
        vRes(I, 1) = dR(V).JPG
        vRes(I, 2) = Split(W, ",")(0)
        vRes(I, 3) = Split(W, ",")(1)
        vRes(I, 4) = Split(W, ",")(2)
    Next W
Next V

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub