Question

编辑....老板给我一个曲线球;

我想在excel中提取多个数据范围的值。范围由日期定义。

sDate     variable    aDate           result
1/2/2012  totalN      1/3/2012        9     
1/2/2012  Nitrate     1/4/2012        ND
1/8/2012  totalN      1/10/2012       7.2
1/9/2012  EC          1/10/2012       8
1/9/2012  totalN      1/12/2012       8.4
1/9/2012  Nitrate     1/12/2012       ND

所以，对于上述情况，我想拉变量，aDate＆amp;每个唯一sDate变量组合的结果。我有一个需要填充的设置输出.xls，格式如下：

date     TriCHL    aDate     DiCHL    aDate     totalN    aDate     Nitrate    aDate     BEN    aDate     EC    aDate
1/2/2012 -         -         -        -         9         1/3/2012  ND         1/4/2012  -      -         -     -
1/8/2012 -         -         -        -         7.2       1/10/2012 -          -         -      -         -     -
1/9/2012 -         -         -        -         8.4       1/12/2012 ND         1/12/2012 -      -         8     1/10/2012

VBA没问题，用唯一值填充数组，然后循环遍历数组并从整个范围中选择，然后提取值？

我迷失了

感谢您的帮助！

修改

这是我的解决方案;可能不是很优雅，但它很实用

Sub ProcessData()

Dim sRng As Range       'starting position of SAMPDATE colrow of input data from lab    ***static***
Dim endsRng As Range    'end SAMPDATE colrow of input data from lab
Dim Rng As Range        'total range of SAMPDATE colrow of input data from lab
Dim row As Object       'row object for input data iteration
Dim sDate As Range      'starting colrow of unique sample dates on output sheet         ***static***
Dim endsDate As Range   'end colrow of unique sample dates on output sheet
Dim totalrng As Range   'total range of unique sample dates on output sheet
Dim datad As String     'sample date on output sheet
Dim datav As String     'chemical variable name on output sheet
Dim i, j As Integer     'used for iterating the output matrix
Dim finalr As String    'final result values from the input lab data
Dim finald As String    'final anadate values from the input lab data

'lets get the last row of the input data
Sheets("data").Select
Set sRng = Sheets("data").Range("f2")
sRng.Select
Do
    ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Value)
Set endsRng = ActiveCell.Offset(-1, 0)

'lets set the total range of the input data as Rng
Set Rng = Sheets("data").Range(sRng.Address & ":" & endsRng.Address)

For Each row In Rng.Rows
    'this is an attempt at being flexible
    If row.Offset(0, 2).Value Like "*1,1-Dichloroethene*" Then
        row.Offset(0, 2).Value = "1,1-Dichloroethylene"
    ElseIf row.Offset(0, 2).Value Like "*cis-1,2-Dichloroethene*" Then
        row.Offset(0, 2).Value = "cis-1,2-Dichloroethylene"
    ElseIf row.Offset(0, 2).Value Like "*Methylene chloride*" Then
        row.Offset(0, 2).Value = "Dichloromethane"
    ElseIf row.Offset(0, 2).Value Like "*Cyanide*" Then
        row.Offset(0, 2).Value = "Free Cyanide"
    ElseIf row.Offset(0, 2).Value Like "*Chlorobenzene*" Then
        row.Offset(0, 2).Value = "Monochlorobenzene"
    ElseIf row.Offset(0, 2).Value Like "*1,4-Dichlorobenzene*" Then
        row.Offset(0, 2).Value = "para-Dichlorobenzene"
    ElseIf row.Offset(0, 2).Value Like "*Tetrachloroethene*" Then
        row.Offset(0, 2).Value = "Tetrachloroethylene"
    ElseIf row.Offset(0, 2).Value Like "*Antimony*" Then
        row.Offset(0, 2).Value = "Total Antimony"
    ElseIf row.Offset(0, 2).Value Like "*Fluoride*" Then
        row.Offset(0, 2).Value = "Total Fluoride"
    ElseIf row.Offset(0, 2).Value Like "*Arsenic*" Then
        row.Offset(0, 2).Value = "Total Arsenic"
    ElseIf row.Offset(0, 2).Value Like "*Barium*" Then
        row.Offset(0, 2).Value = "Total Barium"
    ElseIf row.Offset(0, 2).Value Like "*Beryllium*" Then
        row.Offset(0, 2).Value = "Total Beryllium"
    ElseIf row.Offset(0, 2).Value Like "*Cadmium*" Then
        row.Offset(0, 2).Value = "Total Cadmium"
    ElseIf row.Offset(0, 2).Value Like "*Chromium*" Then
        row.Offset(0, 2).Value = "Total Chromium"
    ElseIf row.Offset(0, 2).Value Like "*Lead*" Then
        row.Offset(0, 2).Value = "Total Lead (as Pb)"
    ElseIf row.Offset(0, 2).Value Like "*Nickel*" Then
        row.Offset(0, 2).Value = "Total Nickel"
    ElseIf row.Offset(0, 2).Value Like "*Selenium*" Then
        row.Offset(0, 2).Value = "Total Selenium (Se)"
    ElseIf row.Offset(0, 2).Value Like "*Thallium*" Then
        row.Offset(0, 2).Value = "Total Thallium"
    ElseIf row.Offset(0, 2).Value Like "*Mercury*" Then
        row.Offset(0, 2).Value = "Total Mercury as Hg"
    ElseIf row.Offset(0, 2).Value Like "*Nitrogen, Total*" Then
        row.Offset(0, 2).Value = "Total Nitrogen"
    ElseIf row.Offset(0, 2).Value Like "*Xylenes, Total*" Then
        row.Offset(0, 2).Value = "Total Xylenes"
    ElseIf row.Offset(0, 2).Value Like "*trans-1,2-Dichloroethene*" Then
        row.Offset(0, 2).Value = "trans-1,2-Dichloroethylene"
    ElseIf row.Offset(0, 2).Value Like "*Trichloroethene*" Then
        row.Offset(0, 2).Value = "Trichloroethylene"
    ElseIf row.Offset(0, 2).Value Like "*TTHMs*" Then
        row.Offset(0, 2).Value = "Trihalomethanes (TTHM)"
    ElseIf row.Offset(0, 2).Value Like "*Vinyl chloride*" Then
        row.Offset(0, 2).Value = "Vinyl Chloride"
    ElseIf row.Offset(0, 2).Value Like "*Total Coliform*" Then
        row.Offset(0, 2).Value = "Total Coliform"
    ElseIf row.Offset(0, 2).Value Like "*1,2-Dichlorobenzene*" Then
        row.Offset(0, 2).Value = "o-Dichlorobenzene"
    ElseIf row.Offset(0, 2).Value Like "*E*Coli" Then
        row.Offset(0, 2).Value = "Fecal Coliform"
    End If
Next row

'lets get the last row of the unique sample dates on the output sheet
Sheets("output").Select
Set sData = Sheets("output").Range("b2")
sData.Select
Do
    ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Value)
Set endsDate = ActiveCell.Offset(-1, 0)

'lets set the total range of the unique sample dates on the output sheet
Set totalrng = Range(sData.Address & ":" & endsDate.Address)

For i = 2 To (totalrng.Count + 1)
    For j = 3 To 77
        datad = Cells(i, 2).Value
        datav = Cells(1, j).Value
        For Each row In Rng.Rows
            If (row.Value = datad And row.Offset(0, 2).Value = datav) Then
                finalr = row.Offset(0, 3).Value
                finald = row.Offset(0, 1).Value
                Exit For
            End If
        Next row
        If (finalr = "--" And finald = "--") Then
            Cells(i, j).Value = ""
            Cells(i, j + 1).Value = ""
        Else
            Cells(i, j).Value = finalr
            Cells(i, j + 1).Value = finald
        End If
        'lets clear the variables for the next iteration
        finalr = "--"
        finald = "--"
        'here we skip the analyze date col
        j = j + 1
    Next j
Next i

End Sub

Answer 1

这应该有效，假设您的数据位于前2列。它在第4和第5列输出结果。

Public Sub getMax()

    Dim data As Variant
    Dim dict As Variant
    Dim d As Variant
    Dim i As Long

    data = UsedRange
    Set dict = CreateObject("Scripting.Dictionary")

    For i = LBound(data, 1) + 1 To UBound(data, 1) 'skips the first line
        If dict.exists(data(i, 1)) Then
            If dict(data(i, 1)) < data(i, 2) Then
                dict(data(i, 1)) = data(i, 2)
            End If
        Else
            dict.Add data(i, 1), data(i, 2)
        End If
    Next i

    ReDim data(1 To dict.Count, 1 To 2) As Variant

    i = 1
    For Each d In dict
        data(i, 1) = d
        data(i, 2) = dict(d)
        i = i + 1
    Next d

    Cells(1, 4).Resize(UBound(data, 1), UBound(data, 2)) = data

End Sub

Answer 2

VBA可以，用一个唯一值填充数组，然后循环遍历数组并从整个范围中选择，或者函数也可以工作。

不需要VBA或公式:)您可以使用数据透视表。请参阅下面的快照。

enter image description here

HTH

西特

excel - 设置/迭代动态范围

2 个答案: