We help IT Professionals succeed at work.

Need help reformatting a spredsheet

Hello

I have a spreadsheet that I want to normalize so I can use it in an MS Access Database.

I have attached it but will explain what I have and then what I want.

This is how it exists:

Column A is the name of a volume table Header Name in Row 1 is VOL_TABLE
Column B is the name of a species Header name in Row 1 is SPECIES
Columns C through AI  with Header name 10, 12, 14, 16, 18, 20......through to 74

Under each column header from row C -> AI is an actual volume. The header name represents the diameter of a tree.

What I want is this spreadsheet converted to 4 columns

COL A - HEADER VOL_TAB
COL B - HEADER SPECIES
COL C - HEADER DIAMETER (comes from the column header from C->AI
COL D - HEADER VOLUME (each individual volume)

Again I have attached the existing spreadsheet and would appreciate any help that you can provide with this. I do not know if this is easier done in Excel of Access. (I am using version 2007)

The spreadsheet has 2 pages. Page 1 is the current state. Page 2 is what I want.

Thanks in advance for help provided.

PBLack

 voltable.xlsx
Comment
Watch Question

BRONZE EXPERT
Commented:
PBlack,

My code below provides the main functionality taht you want. It's also generic so that it's not limited to just your current set-up. There are two prompts - enter "C" to the first and "AI" to the second.

Regards,
Brian.
Option Explicit

Sub Normalise()

Dim xCount As Long, xFound As Boolean
Dim i As Long, j As Long, k As Long, m As Long
Dim xRow As Long, xCol As Long
Dim xInput_Sheet As Worksheet, xNewSheet As Worksheet
Dim xResponse As String, xFirst As Long, xlast As Long

Set xInput_Sheet = ActiveSheet
ActiveSheet.UsedRange.Select

xRow = Range(Selection.Address).Rows.count
xCol = Range(Selection.Address).columns.count

xResponse = InputBox("Normalise", "Enter Column letter of first data field in range " & Selection.Address)
xFirst = 0
On Error Resume Next
    xFirst = Cells(1, xResponse).Column
On Error GoTo 0

If (xFirst = 0) Or (xFirst >= xCol) Then
    MsgBox ("Invalid column selected. Run cancelled")
    Exit Sub
End If

xResponse = InputBox("Normalise", "Enter Column letter of last data field in range " & Selection.Address)
xlast = 0
On Error Resume Next
    xlast = Cells(1, xResponse).Column
On Error GoTo 0

If (xlast <= xFirst) Or (xFirst > xCol) Then
    MsgBox ("Invalid column selected. Run cancelled")
    Exit Sub
End If

xCount = 1

Set xNewSheet = Worksheets.Add
xNewSheet.Activate

'Write headings
k = 1
If xFirst > 1 Then
    For k = 1 To (xFirst - 1)
       xNewSheet.Cells(1, k) = xInput_Sheet.Cells(1, k).Value
    Next
End If

xNewSheet.Cells(xCount, k) = "Measure"
xNewSheet.Cells(xCount, k + 1) = "Value"

If xlast < xCol Then
    m = k + 1
    For k = (xlast + 1) To (xCol)
        m = m + 1
        xNewSheet.Cells(xCount, m) = xInput_Sheet.Cells(1, k).Value
    Next
End If
xCount = xCount + 1

Application.ScreenUpdating = False
    
With xNewSheet
     
        For i = 2 To xRow
        
            For j = xFirst To xlast
    
                xFound = False
                If xInput_Sheet.Cells(i, j).Value <> "" Then
                    
                    xFound = True
                    k = 1
                    If xFirst > 1 Then
                        For k = 1 To (xFirst - 1)
                            .Cells(xCount, k) = xInput_Sheet.Cells(i, k).Value
                        Next
                    End If
                    
                    .Cells(xCount, k) = xInput_Sheet.Cells(1, j).Value
                    .Cells(xCount, k + 1) = xInput_Sheet.Cells(i, j).Value
                    
                    If xlast < xCol Then
                        m = k + 1
                        For k = (xlast + 1) To (xCol)
                            m = m + 1
                            .Cells(xCount, m) = xInput_Sheet.Cells(i, k).Value
                        Next
                    
                    End If
                                
                End If
            
                If xFound Then xCount = xCount + 1
            
            Next j
        
        Next i

End With

Application.ScreenUpdating = True

MsgBox ("Normalisation Complete.")

End Sub

Open in new window

Rob HensonFinance Analyst
BRONZE EXPERT

Commented:
Have you tried using Pivot Table?

See attached.

Thanks
Rob H
 voltable.xls
BRONZE EXPERT

Commented:
Did you really hammer all that out in 10 minutes?

Author

Commented:
WOW that was fast. Works the very best. Thank you so much!
BRONZE EXPERT

Commented:
ScriptAddict,

I wish! Wrote it ages ago (during a boring meeting IIRC, the last time I coded in pencil) and remembered it when I saw PBlack's data.

Regards,
Brian.

Author

Commented:
Well redmondb you really saved me

I thought I was going have to do it manually.

Best experts on the web reside here.

Again thanks for making my day!
BRONZE EXPERT

Commented:
Many thanks, PBLack, glad it helped.

Explore More ContentExplore courses, solutions, and other research materials related to this topic.