-
Dec 7th, 2017, 09:32 AM
#1
Thread Starter
New Member
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
-
Dec 7th, 2017, 12:20 PM
#2
Thread Starter
New Member
Re: Modify data pulling in a query in excel
I also just realized this might be helpful as well:
Sheet1.cls
-
Dec 7th, 2017, 01:51 PM
#3
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?
-
Dec 7th, 2017, 01:52 PM
#4
Thread Starter
New Member
Re: Modify data pulling in a query in excel
-
Dec 7th, 2017, 01:52 PM
#5
Thread Starter
New Member
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
-
Dec 7th, 2017, 03:09 PM
#6
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
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|