Automatic write diagram's titles in Excel VBA - excel

I try to add in a given script some commands in order to automatically update the titles of charts (the charts are produced from the same script provided by Scott Holtzman).
My questions:
1. How can I escape quotes in order to update the text with given variables (I have read this can be done with double quotes ""i"" but it is not working)
2. It is possible to write greek characters and how?
3. It is possible to write with indices or lower case letters or subscripts?
4. How can I change the axes labels? I have defined two but I am changing only the y-axis and not the x-axis.
Here is my script (provided by Scott Holtzman) and my comments waht I am trying to do:
Sub MakeCharts()
Dim ws As Worksheet
Set ws = Sheets("Tabelle1")
Dim dthArray() As Variant
Dim kxArray() As Variant
Dim text1 As String
Dim text2 As String
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim j As Integer
i = 1
j = 1
' Strings for the charts'titles:
dthArray() = Array("0", "0,5", "1", "5", "10")
kxArray() = Array("0", "0,01", "1", "5")
For y = 1 To 259 Step 65
For x = 1 To 259 Step 13
ws.Shapes.AddChart.Select
With ActiveChart
.ChartType = xlXYScatterSmoothNoMarkers
Dim k As Integer
For k = 1 To 13
.SeriesCollection.NewSeries
.SeriesCollection(k).Name = ws.Cells(x, k + 1)
.SeriesCollection(k).XValues = ws.Range(ws.Cells(x + 1, k + 1), ws.Cells(x + 11, k + 1))
.SeriesCollection(k).Values = ws.Range(ws.Cells(x + 1, 1), ws.Cells(x + 11, 1))
.HasTitle = True
Next
.ApplyLayout (1)
Dim sName As String
sName = Replace(.Name, ws.Name & " ", "")
'Updating String for chart's title
text1 = dthArray(i)
text2 = kxArray(j)
' Write chart's title
.ChartTitle.Text = "dth=""text1""" & " " & "dx = ""text2"""
'sigma should be in greek and t as subscript
.Axes(xlValue, xlPrimary).AxisTitle.Text = "sigmat/a"
.Axes(xlValue, xlPrimary).AxisTitle.Text = "eta=y/H"
End With
With ActiveSheet.Shapes(sName)
.IncrementLeft 300
.IncrementTop x * 20
End With
i = i + 1
Next
j = j + 1
Next
End Sub
Any suggestions?

Related

VBA Resize shape according to cell timevalue data

I want to populate my shape according to time range value in 1st Range and 2nd Range cell as shown in the image. Thank you. Your help is much appreciated
https://i.stack.imgur.com/XNNy2.jpg
I've tried this code but it won't work.
Dim z As Range
For Each z In Range("a4:a19").Rows
If z.Value >= Range("F4") Then Exit For
Next z
Dim x As Range
For Each x In Range("a4:a19").Rows
If x.Value >= Range("G4") Then Exit For
Next x
'MsgBox z & x
Dim c
Dim rnrn
c = Rows(3).Find(DateValue("12/11/2022")).Column
'Application.InchesToPoints(10)
Dim LLL As Single, TTT As Single, WWW As Single, HHH As Single
Set rnrn = Range(z.Address, x.Address).Offset(0, c - 1)
LLL = rnrn.Left
TTT = rnrn.Top
WWW = rnrn.Width
HHH = rnrn.Height
With ActiveSheet.Shapes
' .LockAspectRatio = msoFalse
.AddTextbox(msoTextOrientationHorizontal, LLL, TTT + Application.InchesToPoints(Range("F4").Value), WWW, Application.InchesToPoints(Range("F4").Value) + Application.InchesToPoints(Range("G4").Value)).Select
' .Placement = xlMove
' .LockAspectRatio = msoTrue
End With
Dim r1 As Byte, r2 As Byte, r3 As Byte
r1 = WorksheetFunction.RandBetween(0, 255)
r2 = WorksheetFunction.RandBetween(0, 255)
r3 = WorksheetFunction.RandBetween(0, 255)
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(r1, r2, r3)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
With Selection.ShapeRange.TextFrame2.TextRange.Characters.ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
Selection.ShapeRange.TextFrame2.TextRange.Characters.Font.Size = 15
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = Range("F3").Text & " - " & Range("G3").Text
If I understand you correctly....
Below image is an example before running the sub
The expected result after running the sub :
If the image both is similar with your case, then maybe you want to have a look the code below then modify it according to your need. The code don't do any "fancy stuffs", such as coloring, font type, font size, etc.
Sub test()
Dim rg As Range: Dim sTxt As String: Dim eTxt As String
Dim dur: Dim pos
Dim h As Integer: Dim w As Integer
Dim L As Integer: Dim T As Integer
With ActiveSheet
For Each shp In .Shapes: shp.Delete: Next
End With
Set rg = Range("F2", Range("F" & Rows.Count).End(xlUp))
For Each cell In rg
sTxt = Format(cell.Value, "hh:mm AM/PM")
eTxt = Format(cell.Offset(0, 1).Value, "hh:mm AM/PM")
dur = Format(cell.Offset(0, 1).Value - cell.Value, "h:m")
dur = Split(dur, ":")(0) & "." & Application.RoundUp(Split(dur, ":")(1) * 1.666, 0)
pos = Format(cell.Value, "h:m")
pos = Split(pos, ":")(0) & "." & Application.RoundUp(Split(pos, ":")(1) * 1.666, 0)
With Range("D4")
h = dur * .Height: w = .Width
L = .Left: T = .Top + ((pos - 7) * .Height)
End With
With ActiveSheet.Shapes
.AddTextbox(msoTextOrientationHorizontal, L, T, w, h) _
.TextFrame.Characters.Text = sTxt & " - " & eTxt
End With
Next
End Sub
For the textbox size,
the height is coming from subtracting the end time with start time, split the value by ":", then add decimal point ".", then multiply the value after the decimal point with 1.666, so the approx value can be divided by 100, not 60, then multiply by the row height of row 4. The width is coming from column D width.
For the textbox position,
The top position is coming from the start time, then it
s the same process like for the height of the box. The left position is coming from the left position value of column D.

superscript letters in vba string variable

I am looking for how to super/subscript a letter/digit in a VBA string variable. I am working in excel with charts that have axes, titles and chart titles that require s-scripting. Additionally, there is a formula to go in a textbox:
Cpt = Cp0 * e^(-ket) where all the p's, t's and 0 are subscripts. The entire expression, (-ket) is superscripted with embedded subscripting for the e (the e between the k & t). Finally, all the specially formatted string variables will be copied to PowerPoint variables via clipboard/gettext.
Any help / guidance is greatly appreciated.
Pat K.
It is workaround Idea only and the code may not be useful for your purpose depending on source and destination of the data and may be treated as demo only. i have only used excel cells and Text Boxes on a sheet as destination and used PowerPoint Text Boxes as target.
The simple approach is that while picking up String from formatted cells/Text Boxes from excel to a variable, Font Subscript, Superscript information is also to be picked up in a parallel variable (here in a 2D Array). The same font information may be used while writing in PowerPoint. The demo idea have to be Modified/Converted to suit your need.
Demo Screen shot
The demo code
Sub Sscript()
Dim CellStr() As Variant
Dim Rng As Range, Cell As Range
Dim shp As Shape
Dim VarNo As Long, i As Long, j As Long, Txt As String, FntInfo As String
Set Rng = Range("C3:C7") 'Range used for collecting input data and font information for the variable
VarNo = 0
'loop used for Trial may be directly assigned to CellStr by increasing Varno by one for each cell
For Each Cell In Rng.Cells
VarNo = VarNo + 1
ReDim Preserve CellStr(1 To 2, 1 To VarNo)
Txt = Cell.Value
CellStr(1, VarNo) = Txt
FntInfo = ""
For i = 1 To Len(Txt)
If Cell.Characters(i, 1).Font.Subscript = True Then
FntInfo = FntInfo & "A"
ElseIf Cell.Characters(i, 1).Font.Superscript = True Then
FntInfo = FntInfo & "B"
Else
FntInfo = FntInfo & "C"
End If
Next i
CellStr(2, VarNo) = FntInfo
Next Cell
'again loop used for Trial may be directly assigned to CellStr from Textboxes in the sheet
For Each shp In ActiveSheet.Shapes
If shp.Type = msoTextBox Then
VarNo = VarNo + 1
ReDim Preserve CellStr(1 To 2, 1 To VarNo)
Txt = shp.TextFrame2.TextRange.Text
CellStr(1, VarNo) = Txt
FntInfo = ""
For i = 1 To Len(Txt)
If shp.TextFrame2.TextRange.Characters(i, 1).Font.Subscript = msoTrue Then
FntInfo = FntInfo & "A"
ElseIf shp.TextFrame2.TextRange.Characters(i, 1).Font.Superscript = msoTrue Then
FntInfo = FntInfo & "B"
Else
FntInfo = FntInfo & "C"
End If
Next i
CellStr(2, VarNo) = FntInfo
End If
Next
'Start of Trial code in excel to be deleted
For i = 1 To UBound(CellStr, 2)
ActiveSheet.Cells(i, 10).Value = CellStr(1, i)
ActiveSheet.Cells(i, 11).Value = CellStr(2, i)
FntInfo = CellStr(2, i)
For j = 1 To Len(FntInfo)
ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = False
ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = False
If Mid(FntInfo, j, 1) = "A" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = True
If Mid(FntInfo, j, 1) = "B" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = True
Next j
Next
'End of Trial code in excel to be deleted
'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld As Slide
Dim Pshp As Shape
Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)
For i = 1 To UBound(CellStr, 2)
Set Pshp = Sld.Shapes(i)
Pshp.TextFrame.TextRange.Text = CellStr(1, i)
FntInfo = CellStr(2, i)
For j = 1 To Len(FntInfo)
Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = False
Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = False
If Mid(FntInfo, j, 1) = "A" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = True
If Mid(FntInfo, j, 1) = "B" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = True
Next j
Next
End Sub
It is suggested to Add reference of Microsoft PowerPoint Object Library and thanks for asking a good question/challenge to achieve something seemingly not possible but logically possible.
Edit: another more simplistic approach (the 1st half of the String variable contains actual string and 2nd half of the variable contains Font Info) with generalized functions is also added below
Sub Sscript2()
Dim Txt As String, Var1 As String, Var2 As String
Dim Addr As String
Var1 = GetVarFont("C6") ' 1st half of the var contains actual string and 2nd half contain font Info
Var2 = GetVarFont("C7") ' 1st half of the var contains actual string and 2nd half contain font Info
'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld As Slide
Dim Pshp As Object
Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)
WriteShp Sld.Shapes(8).TextFrame.TextRange, Var1
WriteShp Sld.Shapes(9).TextFrame.TextRange, Var2
End Sub
Sub WriteShp(Ptxt As TextRange, VarX As String)
Dim i As Long
Ptxt.Text = Left(VarX, Len(VarX) / 2)
For i = 1 To Len(VarX) / 2
Ptxt.Characters(i, 1).Font.Subscript = False
Ptxt.Characters(i, 1).Font.Superscript = False
If Mid(VarX, Len(VarX) / 2 + i, 1) = "A" Then Ptxt.Characters(i, 1).Font.Subscript = True
If Mid(VarX, Len(VarX) / 2 + i, 1) = "B" Then Ptxt.Characters(i, 1).Font.Superscript = True
Next
End Sub
Function GetVarFont(Addr As String) As String
Dim Txt As String, i As Long
Txt = Range(Addr).Value
GetVarFont = Txt
For i = 1 To Len(Txt)
If Range(Addr).Characters(i, 1).Font.Subscript = True Then
GetVarFont = GetVarFont & "A"
ElseIf Range(Addr).Characters(i, 1).Font.Superscript = True Then
GetVarFont = GetVarFont & "B"
Else
GetVarFont = GetVarFont & "C"
End If
Next i
End Function

Data-labels not displaying in proper order with excel scattered chart using vba

i have an excel sheet with master data with the following information
Row number | candidate | X Value | Y value
I need to plot a scattered chart with X and Y value plotted with row number as data label. Created a VBA to do so, and it worked but datalabel was overlapping. It was fixed with the help of one of our member. But the issue now is, some of the datapoint is showing in different points.
Error picture here, please click
Code as follows
Dim Counter As Integer, ChartName As String, xVals As String, yVals As String
Application.ScreenUpdating = False
Dim c As ChartObject
Set c = Sheets("IImpactchart").ChartObjects("Chart 1")
c.Activate
'Find address of the X values
xVals = ActiveChart.SeriesCollection(1).Formula
xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)
'Not sure why this loop from your code is useful, but let's leave it.
Do While Left(xVals, 1) = ","
xVals = Mid(xVals, 2)
Loop
'Find address of the Y values
yVals = ActiveChart.SeriesCollection(1).Formula
yVals = Mid(yVals, InStr(InStr(yVals, ","), yVals, _
Mid(Left(yVals, InStr(yVals, "!") - 1), 9)))
yVals = Right(yVals, Len(yVals) - InStr(yVals, ","))
yVals = Left(yVals, InStr(InStr(yVals, "!"), yVals, ",") - 1)
'Again, not sure why this loop from your code is useful, but let's leave it.
Do While Left(yVals, 1) = ","
yVals = Mid(yVals, 2)
Loop
Dim DimY As Long, DimX As Long
DimY = 250
DimX = 250
Dim LabelArray() As Long
ReDim LabelArray(1 To DimX, 1 To DimY)
Dim src As Series, pts As Points
Set src = ActiveChart.SeriesCollection(1)
Set pts = src.Points
'Clear labels
src.HasDataLabels = False
For Counter = 1 To Range(xVals).Cells.Count
If (Range(xVals).Cells(Counter, 1).Offset(0, -1).Value = 0) Then
Exit Sub
End If
Dim xCoord As Long, yCoord As Long
xCoord = Range(xVals).Cells(Counter, 1).Value2
yCoord = Range(yVals).Cells(Counter, 1).Value2
If LabelArray(xCoord, yCoord) = 0 Then 'No overlap
LabelArray(xCoord, yCoord) = Counter
pts(Counter).HasDataLabel = True
pts(Counter).DataLabel.Text = Counter + 5
Else 'Overlap
pts(LabelArray(xCoord, yCoord)).DataLabel.Text = _
pts(LabelArray(xCoord, yCoord)).DataLabel.Text & "," & Counter + 5
End If
Next Counter
Application.ScreenUpdating = True
The above issue was solved by changing
yCoord = Range(yVals).Cells(Counter, 1).Value2
to
yCoord = Range(yVals).Cells(Counter, 2).Value2

Bad File Name when using Excel to find words in a Word Document

I'm using the code below to loop through some data on an Excel spreadsheet and open a Word document. I want to then cycle through a word document and find all of the words that were on the Excel sheet. This works okay until I try and find the words on the Excel sheet and then I get a "bad file name" message. I've highlighted the line below where the error occurs. I'm sure it is a syntax error, I just don't know what the correct syntax is. Thanks for the help.......
Dim MyDB() As String
Dim MyCol() As String
Dim MyDBCnt As Integer
Dim MyColCnt As Integer
Dim DBCnt As Integer
Dim ResRow As Integer
Dim r As Integer
Dim x As Integer
Dim PrevRow As Integer
ResRow = 1
r = 5
x = 1
PrevRow = 4
Do Until Len(Trim(Cells(r, 4))) + Len(Trim(Cells(r, 5))) = 0
DoEvents
ReDim Preserve MyDB(1 To x)
If (Trim(Cells(r, 4)) & "." & Trim(Cells(r, 5))) = (Trim(Cells(PrevRow, 4)) & "." & Trim(Cells(PrevRow, 5))) Then
' do nothing
Else
MyDB(x) = Trim(Cells(r, 4)) & "." & Trim(Cells(r, 5))
x = x + 1
End If
r = r + 1
PrevRow = PrevRow + 1
Loop
x = x - 1
MyDBCnt = x
r = 5
x = 1
Do Until Len(Trim(Cells(r, 4))) + Len(Trim(Cells(r, 5))) = 0
DoEvents
ReDim Preserve MyCol(1 To x)
MyCol(x) = Trim(Cells(r, 6))
r = r + 1
x = x + 1
Loop
x = x - 1
MyColCnt = x
Worksheets("Results").Activate
MyLastRow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
ResRow = MyLastRow
Set WordApp = CreateObject("word.Application")
Set WordDoc = WordApp.Documents.Open("R:\Report Web\SQL Doc.docx")
WordApp.Visible = True
WordDoc.Activate
tmp = WordDoc.Name
Dim j As Integer
DBCnt = 1
With WordApp.Selection
Do Until DBCnt > MyDBCnt
DoEvents
With Documents(WordDoc).Find ***ERROR OCCURS HERE
.Text = MyDB(DBCnt)
j = 0
Do While .Execute(Forward:=True) = True
DoEvents
j = j + 1
Loop
End With
If j > 0 Then
MsgBox MyDB(DBCnt) & " was found " & j & " times."
End If
DBCnt = DBCnt + 1
Loop
End With
Find is not a valid property of the Document object. You need to use it on either the Selection or the Range object. For example:
Dim rngFind as Word.Range
Set rngFind = WordDoc.Content
With rngFind.Find
End With

Convert row with columns of data into column with multiple rows in Excel

I hv rows of data:-
TAG SKU SIZE GRADE LOCATION
A001 123 12 A X1
A002 789 13 B X3
A003 456 15 C X5
I need to convert it into:-
A001 123 SIZE 12
A001 123 GRADE A
A001 123 LOCATION X1
A002 789 SIZE 13
A002 789 GRADE B
A002 789 LOCATION X3
A003 456 SIZE 15
A003 456 GRADE C
A003 456 LOCATION X5
I used the below (based on Ben McCormack's suggestion posted on Nov 23 '09) but it doesn't produce the above result :-
Sub NormalizeSheet()
Dim wsOriginal As Worksheet
Dim wsNormalized As Worksheet
Dim strKey As String
Dim clnHeader As Collection
Dim lngColumnCounter As Long
Dim lngRowCounterOriginal As Long
Dim lngRowCounterNormalized As Long
Dim rngCurrent As Range
Dim varColumn As Variant
Set wsOriginal = ThisWorkbook.Worksheets("Original") 'This is the name of your original worksheet'
Set wsNormalized = ThisWorkbook.Worksheets("Normalized") 'This is the name of the new worksheet'
Set clnHeader = New Collection
wsNormalized.Cells.ClearContents 'This deletes the contents of the destination worksheet'
lngColumnCounter = 2
lngRowCounterOriginal = 1
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
' We'll loop through just the headers to get a collection of header names'
Do Until IsEmpty(rngCurrent.Value)
clnHeader.Add rngCurrent.Value, CStr(lngColumnCounter)
lngColumnCounter = lngColumnCounter + 1
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
Loop
'Here we'll reset our Row Counter and loop through the entire data set'
lngRowCounterOriginal = 2
lngRowCounterNormalized = 1
lngColumnCounter = 1
Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
strKey = rngCurrent.Value ' Get the key value from the current cell'
lngColumnCounter = 2
'This next loop parses the denormalized values for each row'
Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
'We're going to check to see if the current value'
'is equal to NULL. If it is, we won't add it to'
'the Normalized Table.'
If rngCurrent.Value = "NULL" Then
'Skip it'
Else
'Add this item to the normalized sheet'
wsNormalized.Range("A" & lngRowCounterNormalized).Value = strKey
wsNormalized.Range("B" & lngRowCounterNormalized).Value = clnHeader(CStr(lngColumnCounter))
wsNormalized.Range("C" & lngRowCounterNormalized).Value = rngCurrent.Value
lngRowCounterNormalized = lngRowCounterNormalized + 1
End If
lngColumnCounter = lngColumnCounter + 1
Loop
lngRowCounterOriginal = lngRowCounterOriginal + 1
lngColumnCounter = 1 'We reset the column counter here because we're on a new row'
Loop
End Sub
Here's an approach going from worksheet to worksheet directly. This might be necessary if the dataset is too big and available memory too small for using arrays. It's likely to be slow.
It uses the same call parameters as reOrgV1, and pretty much the same logic.
It's updated to add "DEFECTS" to the properies. The input looks like:
TAG SKU SIZE GRADE LOCATION DEFECTS
A001 123 12 A X1 3
A002 789 13 B X3 5
A003 456 15 C X5 7
Here's the code.
Public Sub reOrgV2(inSource As Range, inTarget As Range)
'' This version works directly on the worksheet
'' and transfers the result directly to the target
'' given as the top-left cell of the result.
'' **** Changed to add "Defects"
Dim resNames()
Dim propNum As Integer
Dim srcRows As Integer
Dim resRows As Integer
Dim i As Integer
Dim j As Integer
Dim g As Integer
'' Shape the result
resNames = Array("Size", "Grade", "Location", "Defects")
propNum = 1 + UBound(resNames)
'' Row counts
srcRows = inSource.Rows.Count
resRows = srcRows * propNum
'' re-org and transfer source to result range
inTarget = inTarget.Resize(resRows, 4)
g = 1
For i = 1 To srcRows
For j = 0 To 3
inTarget.Item(g + j, 1) = inSource.Item(i, 1) '' Tag
inTarget.Item(g + j, 2) = inSource.Item(i, 2) '' SKU
inTarget.Item(g + j, 3) = resNames(j) '' Property
inTarget.Item(g + j, 4) = inSource.Item(i, j + 3) '' Value
Next j
g = g + propNum
Next i
End Sub
This is the revised call sourcing the wider range.
'' Call ReOrgV2 with input and output ranges
Public Sub test4()
Dim i As Integer
i = Range("InData!A:A").Find("").Row - 2
reOrgV2 Range("InData!A2").Resize(i, 6), [OutData!A1]
End Sub
You can use ADO with Excel. Roughly:
Sub ColsToRows()
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
''This is not the best way to refer to the workbook
''you want, but it is very convenient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Docs\TestBook.xls " _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT [TAG], [SKU], 'SIZE ' & [SIZE] As S, " _
& "'GRADE ' & [GRADE] As G, 'LOCATION ' & [LOCATION] As L " _
& "FROM [Sheet1$] a " _
& "ORDER BY [Tag] "
rs.Open strSQL, cn, 3, 3
''Pick a suitable empty worksheet for the results
With Worksheets("Sheet3")
j = 1 '' Row counter
Do While Not rs.EOF
For i = 2 To 4
.Cells(j, 1) = rs!Tag
.Cells(j, 2) = rs!SKU
.Cells(j, 3) = rs(i)
j = j + 1
Next
rs.MoveNext
Loop
End With
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Here's a really simple solution that assumes the dataset isn't huge. It takes the input range into an array, transforms it into a result array, then moves the array to the specified target. The target is defined by the top left cell.
When it's possible, this approach is orders of magnitude faster than working directly with cells on worksheets.
The test function at the bottom needs you to put an input set on sheet InData and have a sheet OutData defined for the results but your input and output ranges can be anywhere you want.
Option Explicit
Public Sub reOrgV1(inSource As Range, inTarget As Range)
'' This version uses VBA arrays to do the work.
'' Takes a source range, reorganizes it to the target
'' given as the top-left cell of the result.
Dim srcArray As Variant
Dim resArray As Variant
Dim resNames()
resNames = Array("SIZE", "GRADE", "LOCATION")
Dim srcRows As Integer
Dim resRows As Integer
Dim i As Integer
Dim j As Integer
Dim g As Integer
'' Move range into source array
srcArray = inSource.Value
srcRows = UBound(srcArray, 1)
resRows = srcRows * 3
''Build result array
ReDim resArray(1 To resRows, 1 To 3)
'' transfer source to result array
g = 1
For i = 1 To srcRows
For j = 0 To 2
resArray(g + j, 1) = srcArray(i, 1)
resArray(g + j, 2) = srcArray(i, 2)
resArray(g + j, 3) = resNames(j) & " " & srcArray(i, j + 3)
Next j
g = g + 3
Next i
'' Move the results to the target range
inTarget.Resize(resRows, 3).Value = resArray
End Sub
Public Sub test1()
reOrgV1 Range("InData!A2:E4"), Range("OutData!A1")
End Sub

Resources