bloodmilksky
04-18-2017, 05:57 AM
Hi Guys, I hope you are all well.
I am trying to use the values in column A Sheet 1 as names for Ranges on Sheet 2. The ranges size would be 4 cells wide by 12 cells down. I managed to find the below code but cant work out where it defines the range size so that I can adjust it.
Would anyone know either how to amend the below to fit the above requirement or know of some better code to do this?
Sub TransposeRange_new_code() Dim OutRange As Range
Dim x As Long, y As Long
Dim sKey As String
Dim maxCount As Long
Dim data, dic, keys, items, dataout()
Application.ScreenUpdating = False
data = Sheet1.Range("A2:E" & Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row).Value2
Set dic = CreateObject("scripting.dictionary")
Set OutRange = Sheet2.Range("B2")
For x = 1 To UBound(data, 1)
If Trim$(data(x, 1)) <> "_" Then
sKey = Trim$(data(x, 1)) & Chr(0) & Trim$(data(x, 2))
If Not dic.exists(sKey) Then dic.Add sKey, CreateObject("Scripting.Dictionary")
dic(sKey).Add x, Array(data(x, 4), data(x, 5))
If dic(sKey).Count > maxCount Then maxCount = dic(sKey).Count
End If
Next
ReDim dataout(1 To maxCount + 1, 1 To dic.Count * 3)
keys = dic.keys
items = dic.items
For x = LBound(keys) To UBound(keys)
dataout(1, x * 3 + 1) = Split(keys(x), Chr(0))(0)
dataout(1, x * 3 + 2) = Split(keys(x), Chr(0))(1)
For y = 1 To items(x).Count
dataout(1 + y, x * 3 + 1) = items(x).items()(y - 1)(0)
dataout(1 + y, x * 3 + 2) = items(x).items()(y - 1)(1)
Next y
Next
OutRange.Resize(UBound(dataout, 1), UBound(dataout, 2)).Value2 = dataout
For x = 1 To UBound(keys)
OutRange.Offset(0, (x - 1) * 3).Resize(maxCount, 2).Name = "" & validName(Split(keys(x - 1), Chr(0))(0))
With OutRange.Offset(0, (x - 1) * 3 + 1)
.Hyperlinks.Add anchor:=.Cells(1), Address:="mailto://" & .Value2, TextToDisplay:=.Value2
End With
Next
End Sub
any help would be greatly appreciated
many thanks
Jamie
I am trying to use the values in column A Sheet 1 as names for Ranges on Sheet 2. The ranges size would be 4 cells wide by 12 cells down. I managed to find the below code but cant work out where it defines the range size so that I can adjust it.
Would anyone know either how to amend the below to fit the above requirement or know of some better code to do this?
Sub TransposeRange_new_code() Dim OutRange As Range
Dim x As Long, y As Long
Dim sKey As String
Dim maxCount As Long
Dim data, dic, keys, items, dataout()
Application.ScreenUpdating = False
data = Sheet1.Range("A2:E" & Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row).Value2
Set dic = CreateObject("scripting.dictionary")
Set OutRange = Sheet2.Range("B2")
For x = 1 To UBound(data, 1)
If Trim$(data(x, 1)) <> "_" Then
sKey = Trim$(data(x, 1)) & Chr(0) & Trim$(data(x, 2))
If Not dic.exists(sKey) Then dic.Add sKey, CreateObject("Scripting.Dictionary")
dic(sKey).Add x, Array(data(x, 4), data(x, 5))
If dic(sKey).Count > maxCount Then maxCount = dic(sKey).Count
End If
Next
ReDim dataout(1 To maxCount + 1, 1 To dic.Count * 3)
keys = dic.keys
items = dic.items
For x = LBound(keys) To UBound(keys)
dataout(1, x * 3 + 1) = Split(keys(x), Chr(0))(0)
dataout(1, x * 3 + 2) = Split(keys(x), Chr(0))(1)
For y = 1 To items(x).Count
dataout(1 + y, x * 3 + 1) = items(x).items()(y - 1)(0)
dataout(1 + y, x * 3 + 2) = items(x).items()(y - 1)(1)
Next y
Next
OutRange.Resize(UBound(dataout, 1), UBound(dataout, 2)).Value2 = dataout
For x = 1 To UBound(keys)
OutRange.Offset(0, (x - 1) * 3).Resize(maxCount, 2).Name = "" & validName(Split(keys(x - 1), Chr(0))(0))
With OutRange.Offset(0, (x - 1) * 3 + 1)
.Hyperlinks.Add anchor:=.Cells(1), Address:="mailto://" & .Value2, TextToDisplay:=.Value2
End With
Next
End Sub
any help would be greatly appreciated
many thanks
Jamie