Solved

Excel Vba to sum values at an intersection of a column header and several row criteria

Posted on 2011-02-16
17
524 Views
Last Modified: 2012-05-11
Sid's code works perfect for that specific purpose. For another report, I'd need a modified version, where the code should instead of gather just the cell value of the cell at the intersection of column heading "Orange" (or "Apple") and the row with first col value "Daily High Score" it should:

sum all cell values in column with column heading "NetWarehouseStockChange" from all rows that such cell value is
1) larger or smaller than either 2500 or -2500
2) AND has value "C" in column with heading (first row cell value) "ID"
3) AND has value "P3" in column with heading "PAC"
4) AND has value "Cash" in column with heading "PCUS"

The total summed up should be written to wb1. Sheets(1).Range("B4") - If no row/cell is found with such values as defined above, display msg box "No Warehouse Stock move on processed day!"
Dim wb1 As Workbook, wb2 As Workbook

Sub FetchValueFromWildCardFile()
    Dim FlName As String
    Dim aCell As Range, bCell As Range, ExitLoop As Boolean
    Dim OrangeCol As Long, AppleCol As Long
    
    Set wb1 = ActiveWorkbook
    
    FlName = wb1.Sheets("Sheet1").Range("WildcardFilePath").Value
    
    '~~> This will give you the name of the latest modified File
    '~~> You can then use this to open :)
    Set wb2 = Workbooks.Open(GetFileWildCard(GetFileName(FlName), GetFilePath(FlName)))
    
    Set aCell = wb2.Sheets(1).Rows(1).Find(What:="Orange", LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    If Not aCell Is Nothing Then
        OrangeCol = aCell.Column
    End If
    
    Set aCell = wb2.Sheets(1).Rows(1).Find(What:="Apple", LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    If Not aCell Is Nothing Then
        AppleCol = aCell.Column
    End If
    
    If OrangeCol = 0 Or AppleCol = 0 Then
        MsgBox "please ensure that Apple and Orange exist in the row)"
        Exit Sub
    End If
    
    Set aCell = wb2.Sheets(1).Columns(1).Find(What:="Daily High Score", LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    If Not aCell Is Nothing Then
        Set bCell = aCell
        
        If aCell.Offset(, 1) = "G" And aCell.Offset(, 2) = "9Z" Then
            wb1.Sheets("Sheet1").Range("D11").Value = _
            aCell.Offset(, OrangeCol - 1).Value
            wb1.Sheets("Sheet1").Range("D13").Value = _
            aCell.Offset(, AppleCol - 1).Value
        ElseIf aCell.Offset(, 1) = "X" And aCell.Offset(, 2) = "9Z" Then
            wb1.Sheets("Sheet1").Range("D12").Value = _
            aCell.Offset(, OrangeCol - 1).Value
        End If
        
        Do While ExitLoop = False
            Set aCell = wb2.Sheets(1).Columns(1).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                
                If aCell.Offset(, 1) = "G" And aCell.Offset(, 2) = "9Z" Then
                    wb1.Sheets("Sheet1").Range("D11").Value = _
                    aCell.Offset(, OrangeCol - 1).Value
                    wb1.Sheets("Sheet1").Range("D13").Value = _
                    aCell.Offset(, AppleCol - 1).Value
                ElseIf aCell.Offset(, 1) = "X" And aCell.Offset(, 2) = "9Z" Then
                    wb1.Sheets("Sheet1").Range("D12").Value = _
                    aCell.Offset(, OrangeCol - 1).Value
                End If
    
            Else
                ExitLoop = True
            End If
        Loop
    End If
    
    wb2.Close savechanges:=False
End Sub

'~~> Function to get the latest modified File
Function GetFileWildCard(FileName As String, Filepth As String) As String
    Dim strReturn As String
    Dim ModFile As String
    Dim fs As Object, f As Object, s As Date
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    strReturn = Dir(Filepth & FileName, vbNormal)
    Set f = fs.GetFile(Filepth & strReturn)
    moddate = f.DateLastModified
    
    ModFile = Filepth & strReturn
    
    While strReturn <> ""
        Set f = fs.GetFile(Filepth & strReturn)
        If f.DateLastModified > moddate Then
            moddate = f.DateLastModified
            ModFile = Filepth & strReturn
        End If
        
        strReturn = Dir
    Wend
    
    GetFileWildCard = ModFile
    
    Set fs = Nothing: Set f = Nothing
End Function

'~~> Function to get the filename without the path
Function GetFileName(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFileName = GetFileName(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

'~~> Function to get the path except the file name
Function GetFilePath(ByVal strPath As String) As String
    GetFilePath = Replace(strPath, GetFileName(strPath), "")
End Function

Open in new window

0
Comment
Question by:BrdgBldr
17 Comments
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 34911628
Can you upload a sample file?

Sid
0
 

Expert Comment

by:stmoritz
ID: 34911636
ok, will create one. thx  4 ur patience.
0
 

Author Comment

by:BrdgBldr
ID: 34911860
0
 

Author Comment

by:BrdgBldr
ID: 34938469
just checking if anybody is monitoring...  :o)
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 34939638
You don't need a VBA code for this. Simply put this formula in cell B4

=IF(SUMPRODUCT(('[DataSourceForWildcardTest2011021.xls]Sheet1'!$A2:$A1000="C")*('[DataSourceForWildcardTest2011021.xls]Sheet1'!$D2:$D1000="P3")*('[DataSourceForWildcardTest2011021.xls]Sheet1'!$F2:$F1000="CASH")*('[DataSourceForWildcardTest2011021.xls]Sheet1'!$Y2:$Y1000)) > 0,SUMPRODUCT(('[DataSourceForWildcardTest2011021.xls]Sheet1'!$A2:$A1000="C")*('[DataSourceForWildcardTest2011021.xls]Sheet1'!$D2:$D1000="P3")*('[DataSourceForWildcardTest2011021.xls]Sheet1'!$F2:$F1000="CASH")*('[DataSourceForWildcardTest2011021.xls]Sheet1'!$Y2:$Y1000)),"No Warehouse Stock move on processed day!")

Sid
0
 

Author Comment

by:BrdgBldr
ID: 34939696
Thanks Sid. But I can't overcome the wildcard problem with a formular or with this formula in particular, right? There is a random part in the daily source's filename before .xls.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 34939878
Sorry, I didn't quite understand the "wildcard" part?

Sid
0
 
LVL 10

Expert Comment

by:shahzadbux
ID: 34945160
I think the problem is that the data is retrieve from a different file where the file name will change. Using a formula will mean hard coding the file name or using the INDIRECT function.

The INDIRECT function will only work in this case (retrieving from different file) if the other file is open, otherwise it will show #ref or #value

BrdgBldr - can you confirm this is what you mean by "can't overcome the wildcard problem with a formula"
0
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

Author Comment

by:BrdgBldr
ID: 34945927
Yes Sid. you remember it is similar to the solution in the example file.
The file name is not fixed (C:\!ee\DataSourceForWildcardTest20110217_*.xls). It has changing numbers every day (here shown with * wildcard) so that's why the VBA routine needs to get the correct full filename first like shahzadbux mentions, so I can't see a way around using VBA.

0
 
LVL 30

Accepted Solution

by:
SiddharthRout earned 500 total points
ID: 34954540
Sorry was kinda busy...

Sample File Attached.

Sid

Code Used

Dim wb1 As Workbook, wb2 As Workbook

Sub FetchValueFromWildCardFile()
    Dim FlName As String
    Dim aCell As Range, bCell As Range, ExitLoop As Boolean
    Dim CountOccur As Long, OrangeCol As Long, AppleCol As Long
    Dim nSum As Long
    
    Set wb1 = ActiveWorkbook
    
    FlName = wb1.Sheets("Sheet1").Range("WildcardFilePath").Value
    
    '~~> This will give you the name of the latest modified File
    '~~> You can then use this to open :)
    Set wb2 = Workbooks.Open(GetFileWildCard(GetFileName(FlName), GetFilePath(FlName)))
    
    Set aCell = wb2.Sheets(1).Columns(1).Find(What:="C", LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    If Not aCell Is Nothing Then
        Set bCell = aCell
        
        If aCell.Offset(, 3).Value = "P3" And aCell.Offset(, 5).Value = "CASH" And _
        (aCell.Offset(, 24).Value < -2500 Or aCell.Offset(, 24).Value > 2500) Then
            nSum = nSum + aCell.Offset(, 24).Value
        End If

        Do While ExitLoop = False
            Set aCell = wb2.Sheets(1).Columns(1).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                
                If aCell.Offset(, 3).Value = "P3" And aCell.Offset(, 5).Value = "CASH" And _
                (aCell.Offset(, 24).Value < -2500 Or aCell.Offset(, 24).Value > 2500) Then
                    nSum = nSum + aCell.Offset(, 24).Value
                End If
            Else
                ExitLoop = True
            End If
        Loop
    End If
    
    wb1.Sheets("Sheet1").Range("B4").Value = nSum
    
    wb2.Close savechanges:=False
End Sub

'~~> Function to get the latest modified File
Function GetFileWildCard(FileName As String, Filepth As String) As String
    Dim strReturn As String
    Dim ModFile As String
    Dim fs As Object, f As Object, s As Date
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    strReturn = Dir(Filepth & FileName, vbNormal)
    Set f = fs.GetFile(Filepth & strReturn)
    moddate = f.DateLastModified
    
    ModFile = Filepth & strReturn
    
    While strReturn <> ""
        Set f = fs.GetFile(Filepth & strReturn)
        If f.DateLastModified > moddate Then
            moddate = f.DateLastModified
            ModFile = Filepth & strReturn
        End If
        
        strReturn = Dir
    Wend
    
    GetFileWildCard = ModFile
    
    Set fs = Nothing: Set f = Nothing
End Function

'~~> Function to get the filename without the path
Function GetFileName(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFileName = GetFileName(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

'~~> Function to get the path except the file name
Function GetFilePath(ByVal strPath As String) As String
    GetFilePath = Replace(strPath, GetFileName(strPath), "")
End Function

Open in new window

WildcardFileOpenTestFetchValues-.xls
0
 
LVL 30

Assisted Solution

by:SiddharthRout
SiddharthRout earned 500 total points
ID: 34954562
Sorry, I forgot to delete the Line 6 in the above code. Could you do that for me please?

Sid
0
 

Author Closing Comment

by:BrdgBldr
ID: 34956641
perfect. great. excellent. thanks a lot!
0
 

Author Comment

by:BrdgBldr
ID: 34959877
just out of curiosity. as the position of the column headers PAC, PCUS can change and are not fixed, I added a procedure to first get the column of these headers and replaced the fixed figures in the code with these variables like this:

 
Sub FetchValueFromWildCardFile()
    Dim FlName As String
    Dim aCell As Range, bCell As Range, ExitLoop As Boolean
    Dim PacCol As Long, PcusCol As Long, StkChngCol As Long
    Dim nSum As Long
    
    Set wb1 = ActiveWorkbook
    
    FlName = wb1.Sheets("Sheet1").Range("WildcardFilePath").Value
    
    '~~> This will give you the name of the latest modified File
    '~~> You can then use this to open :)
    Set wb2 = Workbooks.Open(GetFileWildCard(GetFileName(FlName), GetFilePath(FlName)))
    
    'PacCol = wb2.Sheets(1).Rows(1).Find("PAC", Range("A1"), xlValues, xlWhole, xlByColumns, xlNext).Row
    'PcusCol = wb2.Sheets(1).Rows(1).Find("PCUS", Range("A1"), xlValues, xlWhole, xlByColumns, xlNext).Row
    'StkChngCol = wb2.Sheets(1).Rows(1).Find("NetWarehouseStockChange", Range("A1"), xlValues, xlWhole, xlByColumns, xlNext).Row
    
    PacCol = Application.WorksheetFunction.Match("PAC", Range("1:1"), 0) - 1
    PcusCol = Application.WorksheetFunction.Match("PCUS", Range("1:1"), 0) - 1
    StkChngCol = Application.WorksheetFunction.Match("NetWarehouseStockChange", Range("1:1"), 0) - 1

    'MsgBox ("PAC = Column " & PacCol & vbNewLine & "PCUS = Column " & PcusCol & vbNewLine & "StkChngCol = Column " & StkChngCol)
    
    Set aCell = wb2.Sheets(1).Columns(1).Find(What:="C", LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    If Not aCell Is Nothing Then
        Set bCell = aCell
        
        If aCell.Offset(, PacCol).Value = "P3" And aCell.Offset(, PcusCol).Value = "CASH" And _
        (aCell.Offset(, StkChngCol).Value < -2500 Or aCell.Offset(, StkChngCol).Value > 2500) Then
            nSum = nSum + aCell.Offset(, StkChngCol).Value
        End If

        Do While ExitLoop = False
            Set aCell = wb2.Sheets(1).Columns(1).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                
                If aCell.Offset(, PacCol).Value = "P3" And aCell.Offset(, PcusCol).Value = "CASH" And _
                (aCell.Offset(, StkChngCol).Value < -2500 Or aCell.Offset(, StkChngCol).Value > 2500) Then
                    nSum = nSum + aCell.Offset(, StkChngCol).Value
                End If
            Else
                ExitLoop = True
            End If
        Loop
    End If
    
    wb1.Sheets("Sheet1").Range("B4").Value = nSum
    
    wb2.Close savechanges:=False
End Sub

Open in new window


It work's fine.

But what I don't understand is why my first attempt

 
PacCol = wb2.Sheets(1).Rows(1).Find("PAC", Range("A1"), xlValues, xlWhole, xlByColumns, xlNext).Row

Open in new window



doesn't work. any idea (or shall I open a related question, though it's only minor)?
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 34960345
try

PacCol = Application.WorksheetFunction.Match("PAC", wb2.Sheets(1).Range("1:1"), 0) - 1

Similarly for others.

Sid
0
 

Author Comment

by:BrdgBldr
ID: 34960499
perfect Sid, many thanks!
0
 

Author Comment

by:BrdgBldr
ID: 35035193
Sid. It's been working perfect every day since. However, today, it stops with an error message "overflow". When debugging, line 37 of solution code ID: 34954540 is highlighted yellow.

when hovering over nSum it shows value 148902... do you have any clue how this figure gets into this variable??... thanks

0
 

Author Comment

by:BrdgBldr
ID: 35402005
Sid... sorry... I don't know if that's included in the points or if you prefer that I open up a new question...

I should add an additional criteria:
column heading: PCURSY
value must be: USD

so I will add:
PCURSYcol = Application.WorksheetFunction.Match("PCURSY", wb2.Sheets(1).Range("1:1"), 0) - 1

Open in new window


but how do I expand the If section afterward?

any help appreciated, many thanks!
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now