Return text when looking up data - excel

I have a spreadsheet which looks like this:
Name Task Date
Mike Go to the beach 10/1/13
Mike Go Shopping 10/2/13
Mike Go to work 10/3/13
Bill Go Hiking 10/1/13
Bill Go to work 10/3/13
I am trying to build another tab to the spreadsheet which will look at the data tab and return the matching text value when the rows and the columns match.
I'm trying to use a formula create a type of pivot table.
The results should look like this:
Name 10/1/13 10/2/13 10/3/13
Mike Go to the beach Go shopping Go to work
Bill Go Hiking *Blank* Go to work
I tried to post images but couldn't since this is my first post.
I hope you can understand what I am asking.

I am no expert in Pivot Tables, I have done it the dumb way - but works. Assumptions:
1) Source Data always on "Sheet1" with those 3 column headers
2) The "Sheet2" will be used to store sorted data
Sub SO_19105503()
Const NameCol As Long = 1
Const TaskCol As Long = 2
Const DateCol As Long = 3
Dim oShSrc As Worksheet, oShTgt As Worksheet, R As Long, C As Long
Dim aNames As Variant, aDates As Variant
Dim lNames As Long, lDates As Long
Dim oRng As Range, oArea As Range
Set oShSrc = ThisWorkbook.Worksheets("Sheet1") ' Source worksheet with original data
oShSrc.Copy Before:=oShSrc
Set oShSrc = ThisWorkbook.Worksheets("Sheet1 (2)") ' Copy of Source worksheet
Set oShTgt = ThisWorkbook.Worksheets("Sheet2") ' Target worksheet to store sorted data
oShSrc.AutoFilterMode = False
' Get unique names (sorted) in column A
aNames = Array()
lNames = 0
R = 1
oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, NameCol), Header:=xlYes
Do
R = R + 1
If Not IsEmpty(oShSrc.Cells(R, NameCol)) And oShSrc.Cells(R, NameCol).Value <> oShSrc.Cells(R - 1, NameCol).Value Then
ReDim Preserve aNames(lNames)
aNames(lNames) = oShSrc.Cells(R, NameCol).Value
lNames = lNames + 1
End If
Loop Until IsEmpty(oShSrc.Cells(R, NameCol))
' Get unique dates (sorted) in column C
aDates = Array()
lDates = 0
R = 1
oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, DateCol), Header:=xlYes
Do
R = R + 1
If Not IsEmpty(oShSrc.Cells(R, DateCol)) And oShSrc.Cells(R, DateCol).Value <> oShSrc.Cells(R - 1, DateCol).Value Then
ReDim Preserve aDates(lDates)
aDates(lDates) = oShSrc.Cells(R, DateCol).Value
lDates = lDates + 1
End If
Loop Until IsEmpty(oShSrc.Cells(R, DateCol))
' Prepare and put data to Target sheet
oShTgt.Range("A1").Value = oShSrc.Range("A1").Value ' Name
' Insert Dates (start from column B on Row 1)
For C = 0 To lDates - 1
oShTgt.Cells(1, C + 2).Value = aDates(C)
Next
' Insert Names (start from Row 2 on Column A)
For R = 0 To lNames - 1
oShTgt.Cells(R + 2, 1).Value = aNames(R)
Next
' Reprocess the source data with Autofilter
For R = 0 To lNames - 1
oShSrc.AutoFilterMode = False ' Remove AutoFilter before apply
' Apply AutoFilter with Criteria of R'th entry in array aNames
oShSrc.UsedRange.AutoFilter Field:=1, Criteria1:="=" & aNames(R)
' Go through Ranges in each Area
For Each oArea In oShSrc.Cells.SpecialCells(xlCellTypeVisible).Areas
For Each oRng In oArea.Rows
' Stop checking if row is more than used
If oRng.Row > oShSrc.UsedRange.Rows.count Then
Exit For
End If
' Check only if the row is below the header
If oRng.Row > 1 Then
For C = 0 To lDates - 1
' Find the matching date and put the "Task" value
If oShSrc.Cells(oRng.Row, DateCol).Value = aDates(C) Then
oShTgt.Cells(R + 2, C + 2).Value = oShSrc.Cells(oRng.Row, TaskCol).Value
Exit For
End If
Next C
End If
Next oRng
Next oArea
Next R
Application.DisplayAlerts = False
oShSrc.Delete ' Delete the temporary data source sheet
Application.DisplayAlerts = True
Set oShSrc = Nothing
Set oShTgt = Nothing
End Sub
Screenshots - Source Data/Result:

Related

Excel VBA ListBox in User Form Populate data from Sheet Range, add row by row after evaluating for a condition

I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub

Excel: Click cell to open the data to another sheet

Here's my draft data
Sheet_name: "FIRST"
The data represents the Pass and fail of X & Y fields. If the Area fails when it comes to X it will be mark as F and if it pass, the field X will mark as P. Same procedure to Field Y
And
Sheet_name: "SECOND"
Here's the summary of the Sheet: "FIRST"
It calculates the counts of passes and fails.
Using the idea of Countif Function.
=COUNTIF(FIRST!B2:B5,"P")
=COUNTIF(FIRST!C2:C5,"F")
What I'm trying to do is,
When you try to click the counts of passes and fails. It will redirect you to new sheet where the sheet gives the data who are the areas passed and failed.
Example:
If I click the "3" under the field of Passed
It will give me something like this,
| X |
Area1 | p |
Area2 | p |
Area4 | p |
Sorry, this one is not my project, homework, or exam.
I just need to understand the logic of opening the data when you click a cell.
Cell-Click to Another Sheet
Copy the code into the Sheets("SECOND") sheet code (in VBA
double-click on "SECOND") and rename a sheet as "THIRD".
In sheet THIRD there will be 2 columns with headers AREA and X. The
headers are excluded from ClearContents.
Below the results will be either for Pass or Fail depending on which
cell was 'clicked' (selected) at the moment.
The Code
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const cStrPass As String = "A3" ' Pass Cell Range
Const cStrFail As String = "B3" ' Fail Cell Range
If Target = Range(cStrPass) Then
CellClick Range("A3")
End If
If Target = Range(cStrFail) Then
CellClick Range("B3")
End If
End Sub
Sub CellClick(CellRange As Range)
Const cVntName1 As Variant = "FIRST"
Const cVntName3 As Variant = "THIRD"
Dim vntSrc As Variant ' Source Array
Dim vntTgt As Variant ' Target Array
Dim lngLastRow As Long ' Source Last Row
Dim i As Long ' Source Row Counter
Dim k As Long ' Target Row Counter
Dim j As Integer ' Source/Target Column Counter
Dim strPF As String ' PassFail String
' Paste Source Range into Source Array.
With Worksheets(cVntName1)
lngLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
vntSrc = .Range("A2", .Cells(lngLastRow, "B"))
End With
' Determine PassFail String.
If CellRange.Column = 1 Then
strPF = "P"
Else
strPF = "F"
End If
' Count rows for Target Array
For i = 1 To UBound(vntSrc)
If vntSrc(i, 2) = strPF Then
k = k + 1
End If
Next
' Write data to Target Array
ReDim vntTgt(1 To k, 1 To 2)
k = 0
For i = 1 To UBound(vntSrc)
If vntSrc(i, 2) = strPF Then
k = k + 1
For j = 1 To UBound(vntSrc, 2)
vntTgt(k, j) = vntSrc(i, j)
Next
End If
Next
' Paste Target Array into Target Range.
With Worksheets(cVntName3)
.Range("A2", "B" & .Rows.Count).ClearContents
.Range("A2").Resize(UBound(vntTgt), UBound(vntTgt, 2)) = vntTgt
.Select
End With
End Sub

Subscript out of range (Extract substrings from multiple comma separated strings macro in Excel)

I have the following list on Sheet1:
COLUMN A COLUMNB COLUMN C
1 ADDRESS Services(s) USED VEHICLE(S) USED
2 Address1 Service4 Vehicle1, Vehicle3, Vehicle4
3 Address1 Service3 Vehicle1, Vehicle3, Vehicle4
4 Address2 Service5 Vehicle1, Vehicle2, Vehicle5
5 Address2 Service2 Vehicle1, Vehicle6
6 Address2 Service1, Service2, Service3, Service4, Service5, Service6 Vehicle2, Vehicle5, Vehicle6
7 Address1 Service1, Service2, Service3, Service4, Service5, Service6 Vehicle2, Vehicle3
On Sheet2, I would like the following output in Column B when I enter "Address1" in cell B4
COLUMN A COLUMN B
4 Address1
12 Service1
13 Service2
14 Service3
15 Service4
16 Service5
17 Service6
50 Vehicle1
51 Vehicle2
52 Vehicle3
53 Vehicle4
54 Vehicle5
56 Vehicle6
Worksheet_Change Code ("Sheet2" module)
Private Sub Worksheet_Change(ByVal Target As Range)
' call Function only if modifed cell is in Column "B"
If Not Intersect(Target, Range("B4")) Is Nothing Then
Application.EnableEvents = False
Call FilterAddress(Target.Value)
End If
Application.EnableEvents = True
End Sub
Sub FilterAddress Code (Regular module)
Option Explicit
Sub FilterAddress(FilterVal As String)
Dim LastRow As Long
Dim FilterRng As Range, cell As Range
Dim Dict As Object
'Dim ID
Dim Vehicle As Variant
Dim VehicleArr As Variant
Dim i As Long, j As Long
Dim Service As Variant
Dim ServiceArr As Variant
Dim x As Long, y As Long
Dim My_Range As Range
With Sheets("Sheet1")
' find last row with data in column "A" (Adress)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set FilterRng = .Range("A1:C" & LastRow)
.Range("A1").AutoFilter
' AutoFilter "Sheet1" according to value in "Sheet2" in Column B
FilterRng.AutoFilter Field:=1, Criteria1:=FilterVal
Set Dict = CreateObject("Scripting.Dictionary")
' create an array with size up to number of rows >> will resize it later
ReDim ServiceArr(1 To LastRow)
j = 1 ' init array counter
For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
' read values from cell to array using the Split function
Service = Split(cell.Value, ",")
For i = LBound(Service) To UBound(Service)
Service(i) = Trim(Service(i)) ' remove extra spaces from string
If Not Dict.exists(Service(i)) Then
Dict.Add Service(i), Service(i)
' save Service Name to array >> will use it later for "Bubble-sort" and paste in "Sheet2"
ServiceArr(j) = Service(i)
j = j + 1 ' increment ServiceArr counter
End If
Next i
Next cell
' resize array up to number of actual Service
ReDim Preserve ServiceArr(1 To j - 1)
End With
Dim ServiceTmp As Variant
' Bubble-sort Service Array >> sorts the Service array from smallest to largest
For i = 1 To UBound(ServiceArr) - 1
For j = i + 1 To UBound(ServiceArr)
If ServiceArr(j) < ServiceArr(i) Then
ServiceTmp = ServiceArr(j)
ServiceArr(j) = ServiceArr(i)
ServiceArr(i) = ServiceTmp
End If
Next j
Next i
' now the "fun" part >> paste to "Sheet2"
With Sheets("Sheet2")
.Range("A1").Value = "ADDRESS"
.Range("B4").Value = FilterVal
.Range("C1").Value = "VEHICLE(S) USED"
' clear contents from previous run
.Range("B12:B17").ClearContents
.Range("B12:B" & UBound(ServiceArr) + 11) = WorksheetFunction.Transpose(ServiceArr)
End With
FilterRng.Parent.AutoFilterMode = False
With Sheets("Sheet1")
' find last row with data in column "A" (Adress)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set FilterRng = .Range("A1:C" & LastRow)
.Range("A1").AutoFilter
' AutoFilter "Sheet1" according to value in "Sheet2" in Column B
FilterRng.AutoFilter Field:=1, Criteria1:=FilterVal
Set Dict = CreateObject("Scripting.Dictionary")
' create an array with size up to number of rows >> will resize it later
ReDim VehicleArr(1 To LastRow)
y = 1 ' init array counter
For Each cell In .Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible)
' read values from cell to array using the Split function
Vehicle = Split(cell.Value, ",")
For x = LBound(Vehicle) To UBound(Vehicle)
Vehicle(x) = Trim(Vehicle(x)) ' remove extra spaces from string
If Not Dict.exists(Vehicle(x)) Then
Dict.Add Vehicle(x), Vehicle(x)
' save Vehicle Name to array >> will use it later for "Bubble-sort" and paste in "Sheet2"
VehicleArr(y) = Vehicle(x)
y = y + 1 ' increment VehicleArr counter
End If
Next x
Next cell
' resize array up to number of actual Vehicle
ReDim Preserve VehicleArr(1 To y - 1)
End With
Dim VehicleTmp As Variant
' Bubble-sort Vehicle Array >> sorts the Vehicle array from smallest to largest
For x = 1 To UBound(VehicleArr) - 1
For y = x + 1 To UBound(VehicleArr)
If VehicleArr(y) < VehicleArr(x) Then
VehicleTmp = VehicleArr(y)
VehicleArr(y) = VehicleArr(x)
VehicleArr(x) = VehicleTmp
End If
Next y
Next x
' now the "fun" part >> paste to "Sheet2"
With Sheets("Sheet2")
.Range("A1").Value = "ADDRESS"
.Range("B4").Value = FilterVal
.Range("C1").Value = "VEHICLE(S) USED"
' clear contents from previous run
.Range("B50:B55").ClearContents
.Range("B50:B" & UBound(VehicleArr) + 49) = WorksheetFunction.Transpose(VehicleArr)
End With
FilterRng.Parent.AutoFilterMode = False
End Sub
When I enter "Address1" in cell B4 on Sheet2, I receive the following error:
Runtime error '9':
Subscript out of range
However, if I save the file with B4 populated and close it, then re open the file, I am able to get the macro to work properly when I edit the cell contents to say either Address1 or Address2.
What is causing the "Subscript out of range" message to appear, and how can I change the code to avoid it? Do I need to update the code in Worksheet_Change Code?
I've also noticed that if I delete the contents of cell B4 on Sheet2 I get the following error:
Run-time error'1004':
No cells were found.
Are these two errors related?
The maximum 'j' isn't bounded by the number of rows on the sheet - it's bounded by the number of elements that you can split out of those rows. There's no way to determine before your code executes what size ServiceArr needs to be dimensioned to. That means depending on the data, you'll get intermittent subscript errors in this section:
ReDim ServiceArr(1 To LastRow) '<-- This is only a guess.
j = 1
For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
Service = Split(cell.Value, ",")
For i = LBound(Service) To UBound(Service)
Service(i) = Trim(Service(i))
If Not Dict.exists(Service(i)) Then
Dict.Add Service(i), Service(i)
ServiceArr(j) = Service(i) '<--Subscript error here if unique elements > LastRow
j = j + 1
End If
Next i
Next cell
The solution is ridiculously easy - get rid of ServiceArr completely. It will always be exactly the same thing as both Dict.Keys and Dict.Values because you're basically keeping a 3rd identical copy of the same data here:
Dict.Add Service(i), Service(i)
ServiceArr(j) = Service(i)
This does almost exactly the same thing as your code, except it gives you a 0 based array instead of a 1 based array:
For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
Service = Split(cell.Value, ",")
For i = LBound(Service) To UBound(Service)
Service(i) = Trim(Service(i))
If Not Dict.exists(Service(i)) Then
Dict.Add Service(i), Empty
End If
Next i
Next cell
ServiceArr = Dict.Keys
'...
'Adjust this to 0 based.
For i = LBound(ServiceArr) To UBound(ServiceArr)
See #YowE3K's comment for why you get the other error.
Well, just wildly guessing but can you try the following:
Option 1
In stead of:
For i = 1 To UBound(ServiceArr) - 1
For j = i + 1 To UBound(ServiceArr)
Write:
For i = 0 To UBound(ServiceArr) - 1
For j = i + 1 To UBound(ServiceArr)
Option 2
In stead of:
j = 1 ' init array counter
Write:
j = 0 ' init array counter
If nothing works, give information about the line of the error. E.g. once you see the error message, press debug and see on which line is colored in yellow.

How to make a dynamic link to a pivot table value?

On tab1 I have a pivot table . When I double click subtotal number 256 on that pivot table, a new worksheet pops up with the details. Everything is just as expected.
On tab2, I have a formula in the field A1 . This formula refers to the subtotal value in the pivot (from tab1)
=GETPIVOTDATA("theId",tab1!$A$1)
A1 shows 256 . . . exactly as in the pivot table .
I need to be able to doulble click this A1 field and see a pop up worksheet with the details (as if I was clicking the pivot table)
The problem is GETPIVOTDATA returns a value only and no link or indirect reference
How can I do this ?
Sorry for the delay, but the weekend was in the middle.
Well here is my answer to how to show the data from a pivot, just with doble click inside a cell, in another sheet that have, the GETPIVOTDATA formula.
Note that in my pivot, I set to "Repeat all items labels" and use a old style pivot.
See the pictures:
For repeat all items labels
and the old style works better for me, and most of all, the macro (VBA)
That been said, let's code!!
All this inside a regular module.
Sub getDataFromFormula(theFormulaSht As Worksheet, formulaCell As Range)
Dim f
Dim arrayF
Dim i
Dim L
Dim iC
Dim newArrayF() As Variant
' Dim rowLables_Sort()
' Dim rowLables_Sort_i()
Dim T As Worksheet
Dim rowRange_Labels As Range
Dim shtPivot As Worksheet
Dim shtPivotName
Dim thePivot As PivotTable
Dim numRows
Dim numCols
Dim colRowRange As Range
Dim colRowSubRange As Range
Dim First As Boolean
Dim nR
Dim nC
Dim myCol
Dim myRow
Dim theRNG As Range
Set T = theFormulaSht 'the sheet where the formula is
'#####################################
'my example formula
'=GETPIVOTDATA("EURO",P!$A$3,"Descripcion","Ingresos Netos de Terceros ,","Mes","July","CuentaCrest","310100","Descripción Crest","Net revenue third parties","Producto","AFR","SubProducto","AFRI","TM1","Net Revenue")
'#####################################
T.Activate 'go!
f = formulaCell.Formula 'get the formula
f = Replace(f, "=GETPIVOTDATA", "") 'delete some things...
f = Replace(f, Chr(34), "")
f = Replace(f, ",,", ",") 'in my data, there is ,, and I need to fix this...
f = Right(f, Len(f) - 1) 'take the formual without parentesis.
f = Left(f, Len(f) - 1)
'####################################
'Restult inside "f"
'EURO,P!$A$3,Descripcion,Ingresos Netos de Terceros ,Mes,July,CuentaCrest,310100,Descripción Crest,Net revenue third parties,Producto,AFR,SubProducto,AFRI,TM1,Net Revenue
'####################################
arrayF = Split(f, ",")
'####################################
'Restult inside arrayF
'EURO,P!$A$3,Descripcion,Ingresos Netos de Terceros ,Mes,July,CuentaCrest,310100,Descripción Crest,Net revenue third parties,Producto,AFR,SubProducto,AFRI,TM1,Net Revenue
'####################################
shtPivotName = arrayF(1) 'set (just) the name of the sheet with the pivot
shtPivotName = Left(shtPivotName, InStr(1, shtPivotName, "!") - 1)
Set shtPivot = Sheets(shtPivotName) 'set the var with the sheet that contents the pivot
Set thePivot = shtPivot.PivotTables(1) 'store the pivot inside
If shtPivot.Visible = False Then 'if the sheet with the pivot is hidden... set visible.
shtPivot.Visible = xlSheetVisible
End If
shtPivot.Activate 'go there!
numRows = thePivot.RowRange.Rows.Count - 1 'the number of rows of the row Range
numCols = thePivot.RowRange.Columns.Count 'here the columns of the same range
Set rowRange_Labels = thePivot.RowRange.Resize(1, numCols)
'with Resize get jus the labels above the RowRange (see the picture (1))
iC = -1
First = True
For Each i In rowRange_Labels 'run the labels
iC = -1 'set the counter
If First Then 'check the flag to see if is the firt time...
First = False 'set the flag to FALSE to go the other part of the IF next time
Set colRowRange = Range(Cells(i.Row, i.Column), Cells(i.Row + numRows - 1, i.Column))
Do
iC = iC + 1 'just to set the counter
Loop While arrayF(iC) <> i.Value 'stop when gets equals and keep the counter
'in the array the values are just strings,
'but we know that is key-value pairs thats why adding +1 to iC we get the real info
'below the label
nR = colRowRange.Find(arrayF(iC + 1)).Row 'just used here
nC = WorksheetFunction.CountIf(colRowRange, arrayF(iC + 1)) + nR - 1 'here we count to set the range
Set colRowSubRange = Range(Cells(nR, i.Column), Cells(nC, i.Column)) 'set the range
myRow = colRowSubRange.Row 'here we get the row of the value
Else
Do 'this is simpler
iC = iC + 1
Loop While arrayF(iC) <> i.Value 'againg...
nR = colRowSubRange.Offset(, 1).Find(arrayF(iC + 1)).Row 'use the SubRange to get others subranges
nC = WorksheetFunction.CountIf(colRowSubRange.Offset(, 1), arrayF(iC + 1)) + nR - 1
Set colRowSubRange = Range(Cells(nR, i.Column), Cells(nC, i.Column))
myRow = colRowSubRange.Row 'idem
End If
Next i
numCols = thePivot.DataBodyRange.Columns.Count 'other part of the pivot... (see the picture (2))
Set theRNG = thePivot.DataBodyRange.Resize(1, numCols) 'just take the above labels
Set theRNG = theRNG.Offset(-1, 0)
iC = -1
For Each L In thePivot.ColumnFields 'for every label...
Do
iC = iC + 1
Loop While L <> arrayF(iC) 'idem
myCol = theRNG.Find(arrayF(iC + 1), , , xlWhole).Column
'always will be just one column...
Next L
Cells(myRow, myCol).ShowDetail = True 'here is the magic!!! show all the data
End Sub
And inside the Worksheet code this:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Left(Target.Formula, 13) = "=GETPIVOTDATA" Then 'Check if there a formula GetPivotData
getDataFromFormula Sheets(Me.Name), Target
End If
End Sub
See this picture to understand what happends to the formula:
The formula is split it as you can see f, into arrayF.
I'm sure you will need to do some changes, but this is very functional and basic, and will be easy to findout what you need.
Also:
This part of code helps me a lot to understand what the pivot had. Using the same data and pivot, I ran the code:
Sub rangePivot()
Dim Pivot As PivotTable
Dim rng As Range
Dim P As Worksheet
Dim D As Worksheet
Dim S As Worksheet
Dim i
Set P = Sheets("P") 'the sheet with the pivot
Set D = Sheets("D") 'the sheet with the data
Set S = Sheets("S") 'the sheet with the cells with the formula
S.Activate 'go
Set Pivot = P.PivotTables("PivotTable1") 'store the pivot here...
For i = 1 To Pivot.RowFields.Count
Cells(i, 1).Value = Pivot.RowFields(i)
Next i
For i = 1 To Pivot.ColumnFields.Count
Cells(i, 2).Value = Pivot.ColumnFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 3).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 4).Value = Pivot.DataLabelRange.Address(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 4).Value = Pivot.DataLabelRange.Address(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataBodyRange.Count
Cells(i, 6).Value = Pivot.DataBodyRange.Address(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 7).Value = Pivot.DataLabelRange.Address(i)
Next i
Cells(1, 8).Value = Pivot.ColumnGrand
Cells(1, 9).Value = Pivot.RowRange.Address
Cells(1, 11).Value = Pivot.TableRange1.Address
Cells(1, 12).Value = Pivot.TableRange2.Address
End Sub
And, as usual, if you need som help & improvement contact me. Hope this help other too.
If you want to do VBA you could set up an event like here:
http://www.ozgrid.com/forum/showthread.php?t=49050
Once you have that set up you need to develop some code that determines where the subtotal cell is (because those are prone to change). Once you have that address you can use Range([subtotal]).ShowDetail = True

VBA Looping/Logic Issue

I am writing a macro in excel for work and I am having trouble. In this scenario there are two sheets, "BU" and "TOPS Information". When the macro is used it is supposed to search every line of "BU" for the value found in "TOPS Information", then go to the next line of "TOPS Information and repeat the process. If it finds a correct match it is supposed to copy a cell and paste it into "TOPS Information".
Here is the code:
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
This Macro obviously only works if "TOPS Information" is selected at the time. Any and all help would be most appreciated. THANKS!
You sorta answered it yourself. Range refers to the current sheet, but when you're bouncing around then you have to qualify it.
Prefix your ranges with the appropriate sheet like so,
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Sheets("TOPS Information").Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Sheets("TOPS Information").Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
Assuming only want to copy the top most found data in BU to TOPS, you can use below.
Sub QIM()
Dim oWS_TOPS As Worksheet, oWS_BU As Worksheet ' Worksheet objects
Dim oRng_TOPS As Range, oRng_BU As Range ' Range objects
Dim R_TOPS As Long, R_BU As Long
Set oWS_TOPS = ThisWorkbook.Worksheets("TOPS Information") ' <-- Replace this "TOPS Information" to match future changes
Set oWS_BU = ThisWorkbook.Worksheets("BU") ' <-- Replace this "BU" to match future changes
R_TOPS = oWS_TOPS.Cells(Rows.Count, "A").End(xlUp).Row
R_BU = oWS_BU.Cells(Rows.Count, "A").End(xlUp).Row
' Search column B of BU for each cell in column C of TOPS
For Each oRng_TOPS In oWS_TOPS.Columns("C").Cells ' <-- Replace this "C" to match future changes
' Exit if row is more than last A column data
If oRng_TOPS.Row > R_TOPS Then Exit For
For Each oRng_BU In oWS_BU.Columns("B").Cells ' <-- Replace this "B" to match future changes
' Exit if row is more than last A column data
If oRng_BU.Row > R_BU Then Exit For
' Check if Ranges match (## See Update ##)
If InStr(1, oRng_TOPS.Value, oRng_BU.Value, vbTextCompare) > 0 Then
' Copy column C of found row in BU to column H of TOPS, then exit
oWS_BU.Cells(oRng_BU.Row, "C").Copy oWS_TOPS.Cells(oRng_TOPS.Row, "H") ' <-- Replace these "C" and "H" to match future changes
Exit For
End If
Next
Next
Set oWS_TOPS = Nothing
Set oWS_BU = Nothing
End Sub
There are many ways to achieve your goal, and this is one of it.
UPDATE Note on comparing cell values (String):
StrComp(S1,S2[,mode]) only return 3 values {-1, 0, 1} to indicate if S1 is less/equal/greater than S2. If you want an exact match (case sensitive and exact spacing), use If StrComp(S1,S2) = 0 Then.
InStr([i,]S1,S2[,mode]) only returns positive values - it returns the character location of first appearance of S2 in S1. If S2 is not found then it returns zero.
You can also use Trim(sText) to remove leading/ending spaces of sText.
Hope below screenshot says more.

Resources