Arrays

Use the foll.<pre>Option Explicit

Sub ConvertToRelational()
Dim commonCols As Long, i As Long, j As Long, _
currRegion As Range, dest As Range
commonCols = Application.InputBox("Please indicate the number of common columns", Type:=1)
If commonCols = 0 Then Exit Sub
Set currRegion = ActiveCell.CurrentRegion
Set dest = Worksheets.Add.Range("A2")
With currRegion
For i = .Row To currRegion.Rows(.Rows.Count).Row
For j = .Column + commonCols To .Columns(.Columns.Count).Column
.Parent.Cells(i, .Column).Resize(1, commonCols).Copy
dest.PasteSpecial xlPasteValues
dest.Offset(0, commonCols).Value = .Parent.Cells(i, j)
Set dest = dest.Offset(1, 0)
Next j
Next i
End With
End Sub</pre>.
Select any cell in the range that contains the data you need reorganized. Then, run the macro (Tools | Macro > Macros...). It will add a new worksheet and put the result in that worksheet.

Hi,

This is nowhere near as elegant as Tushar's offering (Nice job!), but this rough coding allows you to use any continuous range in the selected area as your repeating columns.<pre>Sub test()
Dim SelRange As Range
Dim KeepCols As Range
Dim Cell As Range
Dim x As Integer
Dim Counter As Integer
Dim TotalColsCt As Integer
Dim KeepColsCt As Integer
Dim dest As Range

Set SelRange = Selection
With SelRange
If .Rows.Count<> 1 Then Exit Sub
TotalColsCt = .Columns.Count
On Error Resume Next
Set KeepCols = Application.InputBox("Enter the common columns", Type:=8)
On Error GoTo 0
Err.Clear
If KeepCols Is Nothing Then
Exit Sub
ElseIf KeepCols.Columns.Count >= TotalColsCt Then
Exit Sub
Else
KeepColsCt = KeepCols.Columns.Count
End If

ReDim KeepArray(1 To KeepColsCt)
KeepArray = WorksheetFunction.Transpose(WorksheetFunction.Transpose(KeepCols))
ReDim DataArray(1 To TotalColsCt - KeepColsCt)
End With

Counter = 0
For Each Cell In SelRange
If Intersect(Cell, KeepCols) Is Nothing Then
Counter = Counter + 1
DataArray(Counter) = Cell
End If
Next Cell

Set dest = Worksheets.Add.Range("A1")

With dest
For x = 1 To TotalColsCt - KeepColsCt
.Offset(x - 1, 0).Resize(1, UBound(KeepArray) - LBound(KeepArray) + 1) = KeepArray
.Offset(x - 1, UBound(KeepArray) - LBound(KeepArray) + 1) = DataArray(x)
Next x
End With

End Sub</pre>

Definitely go with Tushar's code for your particular purposes. This was just an idea to make it a bit more flexible.

_________________
Bye,
Jay
This message was edited by Jay Petrulis on 2002-12-09 19:10

Tushar,

Very nice solution

I´ve made a screendump on that one!

Kind regards,
Dennis

Tusharm & Jay...

WOW, you guys rock! Thanks for the code. They work great!

I didn't realize until I ran your code that I overlooked something though. The first line of data in this array contains column/field names. They are currently @DEEP, @NAME, @DESC, and P1 to P12. The real meat of the data starts in row 2 of the array.

The twist I forgot was that the columns should be named (from line 1 or renamed) and I actually need 5 columns rather than the 4 I originally thought. Columns 1,2&3 work great with the code. Column 4 would be named PERIOD and contain the appropriate column/field title (P1,P2,P3..P12 or 1,2,3..12) and finally the fifth column should be named PLAN and contain the actual data from the table as the code provides.

Thanks for the help, it is truly appretiated.

Yeah, I figured the 'forgot about the header' was coming.

While http://www.mrexcel.com/tip018.shtml deals with the subject, here's a somewhat more general solution. It is not perfect in that it doesn't add headers to the new table it creates.<pre>Sub ConvertToRelational()
Dim commonCols As Long, i As Long, j As Long, _
currRegion As Range, dest As Range
Const hasHeader As Boolean = True
commonCols = Application.InputBox("Please indicate the number of common columns", Type:=1)
If commonCols = 0 Then Exit Sub
Set currRegion = ActiveCell.CurrentRegion
Set dest = Worksheets.Add.Range("A2")
With currRegion
For i = .Row + IIf(hasHeader, 1, 0) To currRegion.Rows(.Rows.Count).Row
For j = .Column + commonCols To .Columns(.Columns.Count).Column
.Parent.Cells(i, .Column).Resize(1, commonCols).Copy
dest.PasteSpecial xlPasteValues
If hasHeader Then
dest.Offset(0, commonCols).Value = .Parent.Cells(.Row, j)
dest.Offset(0, commonCols + 1).Value = .Parent.Cells(i, j)
Else
dest.Offset(0, commonCols).Value = .Parent.Cells(i, j)
End If
Set dest = dest.Offset(1, 0)
Next j
Next i
End With
End Sub</pre>.

_________________
Regards,

Tushar
www.tushar-mehta.com
This message was edited by tusharm on 2002-12-11 12:50

Tushar,

Exactly what I needed, I can live with typing in my own column headings! Thanks so very much for your troubles.

Your website is terrific too. I took a little sojurn there and found the information extremely informative and interesting.