Microsoft Office Tutorials and References
In Depth Information
Converting Data to a Tabular Format
On Error GoTo 0¶
'Did the user cancel?¶
If RngOrig Is Nothing Or RngDest Is Nothing Then Exit Sub¶
'Multiple selections in the origin? (can't do that...)¶
If RngOrig.Areas.Count > 1 Then¶
MsgBox "Please select only one range and try again", _¶
vbCritical¶
Exit Sub¶
End If¶
'Use only first cell of RngDest as the destination¶
Set RngDest = RngDest(1)¶
'Ask for the number of fixed columns (the variable will¶
'be the difference)¶
FixedColumnCount = CLng(Application.InputBox( _¶
Prompt:="How many columns are fixed ?" & vbCrLf & _¶
"Note that the macro assumes these columns go " & _¶
"from left to right", Title:="Fixed columns", Type:=1))¶
If FixedColumnCount < 1 Then Exit Sub¶
VarColumnCount = RngOrig.Columns.Count - FixedColumnCount¶
'Turn off screen updating¶
Application.ScreenUpdating = False¶
'Put the headers¶
' First, the fixed ones¶
RngDest.Resize(1, _¶
FixedColumnCount).Value = RngOrig(1).Resize(1, _¶
FixedColumnCount).Value¶
' Next, two generic (Question and Value)¶
RngDest.Offset(0, FixedColumnCount).Resize(1, _¶
2).Value = Array("Question", "Value")¶
'Ok, convert the data, loop through the RngOrig range¶
On Error GoTo err_h 'Trap errors¶
For i = 1 To RngOrig.Rows.Count - 1 'Exclude the headers¶
With RngDest.Offset(VarColumnCount * i - VarColumnCount + 1, _¶
0).Resize(VarColumnCount, FixedColumnCount)¶
'Place the fixed value, it will be repeated VarColumnCount times¶
.Value = RngOrig.Offset(i).Resize(1, _¶
FixedColumnCount).Value¶
'Now, for the questions (Data needs to be transposed)¶
.Offset(, FixedColumnCount).Resize(, _¶
1).Value = Application.Transpose(RngOrig.Offset(0, _¶
FixedColumnCount).Resize(1, VarColumnCount).Value)¶
'Finally, the values¶
.Offset(, FixedColumnCount + 1).Resize(, _¶
1).Value = Application.Transpose(RngOrig.Offset(i, _¶
FixedColumnCount).Resize(1, VarColumnCount).Value)¶
End With¶
Next i¶
err_h:¶
If Err.Number <> 0 Then¶
MsgBox "The following error occured: " & vbCrLf & "Error: " _¶
& Err.Number & ", " & Err.Description, vbCritical¶
Exl
Search JabSto ::




Custom Search