Horizontal Lookup

[SamPaulRoger]

Hi,

I have a sheet which contains a data output of all my orders under each date and in another sheet I have a list of all the unique orders. I am trying to do a count of any duplicates that are greater than or equal to today's date. For example if today is 7/27, I want to find all duplicates that start from 7/27 to the end of the data set (Nothing before).

7/24	7/25	7/26	7/27	7/28	7/29	7/30	7/31	8/1	8/2
GEE100	ACD107	ABC102	ABC100			DEF501			ABC100
DBC100	GEE101		ABC102			DEF501			ABC102
ASD104	GED104		ABC103			DEF502			ABC103

<tbody>
</tbody>

On sheet2 my list of Pre-Populated ID's and the script output

ID	Duplicates
ABC100	2
ABC101
DEF501	2
DEF502	1

<tbody>
</tbody>

 

[Peter_SSs]

Try this, copied down.

Excel Workbook
	A	B	C	D	E	F	G	H	I	J
1	24 Jul	25 Jul	26 Jul	27 Jul	28 Jul	29 Jul	30 Jul	31 Jul	1 Aug	2 Aug
2	GEE100	ACD107	ABC102	ABC100			DEF501			ABC100
3	DBC100	GEE101		ABC102			DEF501			ABC102
4	ASD104	GED104		ABC103			DEF502			ABC103
5
6
7
8	ID	Duplicates
9	ABC100	2
10	ABC101	0
11	DEF501	2
12	DEF502	1
Count

 

[SamPaulRoger]

That worked really well, Is there a way this can be done through VBA with an evaluate based on last row/column? The data set I use changes on a day by day basis and can be as many as 200 columns, but never more than 1000 rows... Another reason I would like this to be in VBA is because this gets distributed to multiple people who have a habit of deleting formulas and then complain their file is broken...

 

[Peter_SSs]

Is there a way this can be done through VBA ...

Good idea to state that up-front if you are looking for a particular method.

Assuming that ..
- original data is on 'Sheet1' starting at cell A1
- 'Sheet2' table also starts at cell A1 with headings in row 1
.. try this on a copy of your workbook.

Sub CountAfterDate()
  Dim a As Variant, b As Variant
  Dim d As Object
  Dim lr As Long, fc As Long, lc As Long, i As Long, j As Long, cols As Long, ub2 As Long
  
  With Sheets("Sheet1")
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    For i = 1 To lc
      If .Cells(1, i).Value = Date Then
        fc = i
        Exit For
      End If
    Next i
    If fc <> 0 Then
      Set d = CreateObject("Scripting.Dictionary")
      cols = lc - fc + 1
      lr = .Columns(fc).Resize(, cols).Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      a = .Columns(fc).Resize(, cols).Resize(lr).Value
      ub2 = UBound(a, 2)
      For i = 2 To UBound(a)
        For j = 1 To ub2
          d(a(i, j)) = d(a(i, j)) + 1
        Next j
      Next i
      With Sheets("Sheet2")
        b = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
        For i = 1 To UBound(a)
          b(i, 2) = d(b(i, 1))
        Next i
        .Range("A2:B2").Resize(UBound(b)).Value = b
      End With
    End If
  End With
End Sub

 

[kvsrinivasamurthy]

VBA code

Sub Macro1()
Dim LR As Long, LC As Long, TA As Long, TB As Long, DTno As Long, X As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim celVal
Dim Frng As Range


Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Sh1.Activate
Range("A1").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
LC = Range("A1").End(xlToRight).Column
DTno = Date
X = Range("A1:ZZ1").Find(What:=DTno, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Column


Sh2.Range("A1:B1").Value = Array("ID#", "Duplicates")


For TB = X To LC
    For TA = 2 To LR
    celVal = Sh1.Cells(TA, TB).Value
    
    If celVal <> "" Then
    Set Frng = Sh2.Range("A:A").Find(What:=celVal, After:=Sh2.Range("A1"), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
    If Not Frng Is Nothing Then
    Frng.Offset(0, 1) = Frng.Offset(0, 1) + 1
    Else
    Sh2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = celVal
    Sh2.Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = 1
    End If
    End If
    
    Next TA


Next TB
End Sub