Modify data pulling in a query in excel-VBForums
Results 1 to 6 of 6

Thread: Modify data pulling in a query in excel

  1. #1

    Thread Starter
    New Member
    Join Date
    Dec 2017
    Posts
    4

    Modify data pulling in a query in excel

    Hi all!

    I need some assistance. I have a macro in an employee Span of Control document that outputs one extra field of data that I don't need nor want. I've looked everywhere in the code and can't figure out how to not have it pull in.

    For instance, in the below information, the EmpID is pulling into the Reporting Chain by ID as the last entry, and I do not want that. The reporting chain by ID field can go up to 6 entries deep.

    EmpID Supervisor Name Reporting Chain by ID
    1772 1772
    1765 Mickey Mouse 1772|1765

    I'm attaching the code used to create the query, any help would be appreciated. Module1.bas

  2. #2

    Thread Starter
    New Member
    Join Date
    Dec 2017
    Posts
    4

    Re: Modify data pulling in a query in excel

    I also just realized this might be helpful as well:

    Sheet1.cls

  3. #3
    Fanatic Member
    Join Date
    Oct 2001
    Location
    Idaho Falls, Idaho USA
    Posts
    911

    Re: Modify data pulling in a query in excel

    Can you post the code from Mudule1.bas her, in code tags, so we don't have to download it?

  4. #4

    Thread Starter
    New Member
    Join Date
    Dec 2017
    Posts
    4

    Re: Modify data pulling in a query in excel

    Code:
    Sub DoReportingChain()
        ' shg 2008/2010
            
        Dim rInp        As Range                    ' dynamic input range {emp name, emp ID, sup name}
        Dim rOut        As Range                    ' output range {emp name, report chain, # reports, level}
        
        Dim dic         As Scripting.Dictionary     ' key = sNamEmp, item = {sIdNEmp, sNamSup, sReport, nReports}
        Dim vKey        As Variant                  ' dictionary key (employee name)
        Dim vItmEmp     As Variant                  ' dictionary item for employee
        Dim vItmSup     As Variant                  ' dictionary item for supervisor
    
        Dim sNamEmp     As String                   ' employee name
        Dim sIdNEmp     As String                   ' employee ID
        Dim sReport     As String                   ' reporting chain
        Dim sNamSup     As String                   ' supervisor name
        Dim nGod        As Long                     ' # people with no supervisor (==1)
    
        Dim i           As Long                     ' scratch index
        Dim cell        As Range                    ' scratch for-each loop variable
    
        Dim WF          As WorksheetFunction
    
        Set rInp = ActiveSheet.Range("tblInp")
        If rInp.Rows.Count < 2 Then
            MsgBox "Nothing to do!"
            GoTo OuttaHere
        End If
        
        Set dic = New Scripting.Dictionary
        With dic
            '===================================
            ' read employee data (names & IDs must be unique)
            '===================================
            Application.StatusBar = "Step 1 of 5: Reading input data ..."
    
            For Each cell In rInp.Columns(1).Cells
                sNamEmp = cell.Text
                If .Exists(sNamEmp) Then
                    cell.Select
                    MsgBox "Duplicate employee name!"
                    GoTo OuttaHere
    
                Else
                    sIdNEmp = cell.Offset(, 1).Text
                    If Len(sIdNEmp) = 0 Then
                        cell.Select
                        MsgBox "Employee has no ID!"
                        GoTo OuttaHere
                    End If
    
                    sNamSup = cell.Offset(, 2).Text
                    If Len(sNamSup) = 0 Then
                        nGod = nGod + 1
                        If nGod > 1 Then
                            cell.Select
                            MsgBox "Second employee with no Supervisor!"
                            GoTo OuttaHere
                        End If
                    End If
    
                    .Add Key:=sNamEmp, Item:=Array(sIdNEmp, sNamSup, sIdNEmp, 0&)
                End If
            Next cell
    
            If nGod <> 1 Then
                MsgBox "Exactly one employee must have a blank for Supervisor"
                GoTo OuttaHere
            End If
    
            '===================================
            ' create reporting chain for each employee
            '===================================
            Application.StatusBar = "Step 2 of 5: Creating reporting chains ..."
    
            For Each vKey In .Keys
                vItmEmp = .Item(vKey)
                sIdNEmp = vItmEmp(0)
                sNamSup = vItmEmp(1)
                sReport = vItmEmp(2)
    
                Do While Len(sNamSup)
                    If Not .Exists(sNamSup) Then
                        MsgBox "Supervisor """ & sNamSup & """ for employee """ & vKey & """ does not exist!"
                        GoTo OuttaHere
    
                    Else
                        vItmSup = .Item(sNamSup)
    
                        If InStr(sReport, vItmSup(0)) Then
                            MsgBox vKey & "has a circular reference!" & vbLf & _
                                   vItmSup(0) & " " & sReport
                            GoTo OuttaHere
    
                        Else
                            vItmSup(3) = vItmSup(3) + 1    ' increment number of reports
                            .Item(sNamSup) = vItmSup
    
                            sReport = vItmSup(0) & "|" & sReport
                            sNamSup = vItmSup(1)
                        End If
                    End If
                Loop
                vItmEmp(2) = sReport
                .Item(vKey) = vItmEmp
            Next vKey
        End With
    
        '===================================
        ' write out results
        '===================================
        Application.Calculation = xlCalculationManual
        Application.StatusBar = "Step 3 of 5: Writing results ..."
    
        Set WF = WorksheetFunction
        Set rOut = ActiveSheet.Range("tblOut").Resize(dic.Count, 6)
        With rOut
            .ClearContents
            .HorizontalAlignment = xlGeneral
            
            .Columns("A:D").NumberFormat = "@"
            .Columns("E:F").Resize(, 2).NumberFormat = "0_);;"
    
            .Columns("A").Value = WF.Transpose(dic.Keys)
            .Columns("B:E").Value = WF.Transpose(WF.Transpose(dic.Items))
            
            Application.StatusBar = "Step 4 of 5: Calculating indents ..."
            With .Columns(6)
                .FormulaR1C1 = "=SetIndent(rc[-5], len(rc[-2]) - len(substitute(rc[-2], ""|"", """")))"
                .Value = .Value
            End With
            
            Application.StatusBar = "Step 5 of 5: Sorting ..."
            .Sort Key1:=.Cells(1, 4), Order1:=xlAscending, _
                  Orientation:=xlTopToBottom, Header:=xlNo
    
            .EntireColumn.AutoFit
        End With
    
    OuttaHere:
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
        Beep
    End Sub
    
    Function SetIndent(r As Range, ByVal Level As Long) As Variant
        ' shg 2008
    
        ' Sets the indent level of r from 0 to 15 and returns the indent level
    
        Dim cell        As Range
    
        If Level < 0 Then
            Level = 0
            SetIndent = "Min is 0!"
        ElseIf Level > 15 Then
            Level = 15
            SetIndent = "Max is 15!"
        Else
            SetIndent = Level
        End If
    
        For Each cell In r
            With cell
                If Level - .IndentLevel Then .InsertIndent Level - .IndentLevel
            End With
        Next cell
    End Function

  5. #5

    Thread Starter
    New Member
    Join Date
    Dec 2017
    Posts
    4

    Re: Modify data pulling in a query in excel

    Sure! Just did!

  6. #6
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,026

    Re: Modify data pulling in a query in excel

    so which doreportingchain are you using?, the sheet or the module?

    can you post a workbook (zip first) with some sample data for testing, preferably with current result and desired result included
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.