Pull Data from Sheet3 to Sheet1

[richardSmith]

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 :)11222

Thanks to all and cheers:help

[GTO]

Greetings Richard,

Try - In a Standard Module:

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


Hope that helps,

Mark

[richardSmith]

Greetings Richard,

Try - In a Standard Module:

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


Hope that helps,

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?

DISREGARD --
I changed the line of --- TO and it is functioning perfectly!

Private DIC
Dim DIC

[GTO]

OOpsie! Sorry about that; i forgot to change it when moving it from module-level to procedure-level. Glad it's now working :-)

[richardSmith]

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:

http://www.vbaexpress.com/forum/showthread.php?48855-Pull-Data-From-One-Worksheet-To-Another&p=304413

Can you please advice once you get a moment to review. Thanks in advance -- Rich