Printable View
Sheet 3 is in the format that my query is returning from. I need to somehow programatically pull the data from my sheet3 into the correspodning and correct row on sheet1. Can someone help me with thsi?
See my attachment for further :)Attachment 11222
Thanks to all and cheers:help
Greetings Richard,
Try - In a Standard Module:
Hope that helps,Code:Option Explicit
'Sheet 3 is in the format that my query is returning from. I need to somehow
'programatically pull the data from my sheet3 into the correspodning and correct row on sheet1.
'NOTE: 'Sheet 3' in your example file had a CodeName of 'Sheet2'. I am using the CodeName.
Sub Example()
Private DIC As Object ' Scripting.Dictionary
Dim rngDataLastCell As Range
Dim arrDataRaw As Variant
Dim arrDataLayedOut As Variant
Dim Keys As Variant
Dim y As Long
Dim yRow As Long
Dim x As Long
Dim xCol As Long
With Sheet2
'// Find last cell with data in Col A, from row 2 downward. //
Set rngDataLastCell = RangeFound(.Range(.Cells(2, 1), .Cells(.Rows.Count, 1)))
'// In case no data. //
If rngDataLastCell Is Nothing Then
MsgBox "No data...", vbInformation, vbNullString
Exit Sub
End If
'// If we got here, we're good-to-go, so set a reference to a new dictionary and //
'// plunk the raw data into an array. //
Set DIC = CreateObject("Scripting.Dictionary")
arrDataRaw = .Range(.Range("A2"), rngDataLastCell).Resize(, 3).Value
End With
'// Just build a collection of unique keys, we don't need the items. //
For y = 1 To UBound(arrDataRaw, 1)
DIC.Item(arrDataRaw(y, 1)) = Empty
Next
'// Size an output array; I am presuming 'weeks' should run to 52. //
ReDim arrDataLayedOut(1 To (5 * DIC.Count), 1 To 53)
'// Plunk the dictionary Keys into an array (for late-binding). //
Keys = DIC.Keys
'// Looping through the Keys array, pre-fill our output array. //
For y = 0 To UBound(Keys, 1)
arrDataLayedOut(((y + 1) * 5) - 4, 1) = Keys(y)
arrDataLayedOut(((y + 1) * 5) - 3, 1) = "Week #"
For x = 1 To 52
arrDataLayedOut(((y + 1) * 5) - 3, x + 1) = x
Next
arrDataLayedOut(((y + 1) * 5) - 2, 1) = "Count"
Next
'// Loop through the first 'column' of our raw data, grabbing and correctly placing //
'// data into our output array. //
For y = 1 To UBound(arrDataRaw, 1)
yRow = Application.Match(arrDataRaw(y, 1), Application.Index(arrDataRaw, 0, 1), 0)
xCol = Application.Match(arrDataRaw(y, 3), Application.Index(arrDataLayedOut, yRow + 1, 0), 0)
arrDataLayedOut(yRow + 2, xCol) = arrDataRaw(y, 2)
Next
ThisWorkbook.Worksheets.Add(After:=Sheet2).Range("A1").Resize(UBound(arrDataLayedOut), UBound(arrDataLayedOut, 2)).Value _
= arrDataLayedOut
End Sub
Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
Mark
Is the Private DIC line a reference I need to add when I compile in Excel 2007 I get a compile error of invalid attribute in Sub or Function What dictionary reference would I need to add?Quote:
Originally Posted by GTO
DISREGARD --
I changed the line of --- TO and it is functioning perfectly!
[vba]
Private DIC
Dim DIC
[/vba]
OOpsie! Sorry about that; i forgot to change it when moving it from module-level to procedure-level. Glad it's now working :-)
Hello m8 if I expand the data that is on sheet2 I get a Type Mismatch error :( --- Since I marked this thread as solved I opened a new one here:Quote:
Originally Posted by GTO
http://www.vbaexpress.com/forum/show...other&p=304413
Can you please advice once you get a moment to review. Thanks in advance -- Rich