martinctc
9/29/2017 - 5:08 PM

This macro takes a percentage cross-table (with headers, with "total" at righter-most column) and returns a new index table on a new sheet,

[Index Creator] This macro takes a percentage cross-table (with headers, with "total" at righter-most column) and returns a new index table on a new sheet, with exactly the same dimensions. #Excel

IndexCreator.vbs
content_copyfile_download
Sub IndexCreator()

Dim rng, totrng As Range
Dim orignam, newnam As String
Dim tots() As Variant
Dim i, j As Long

orignam = ActiveSheet.Name
Set rng = Application.InputBox("Please select source table area (include headers)", "Source table", Default:=Selection.Address, Type:=8)


Sheets.Add(After:=Sheets(Sheets.Count)).Name = "IFull" & Format(Date, "dd-mm-yy") & "@" & Format(Time, "hhmmss")
newnam = "IFull" & Format(Date, "dd-mm-yy") & "@" & Format(Time, "hhmmss")

nrow = rng.Rows.Count
ncol = rng.Columns.Count

Debug.Print nrow
Debug.Print ncol

Set totrng = Range(rng.Cells(2, ncol), rng.Cells(nrow, ncol))
Debug.Print totrng.Address

tots = totrng.Value

'Debug.Print LBound(tots)
'Debug.Print UBound(tots)

i = 1
Debug.Print rng.Cells(i + 1, 2).Value
Debug.Print tots(1, 1)

For j = 1 To ncol - 1
    For i = 1 To nrow - 1
        Worksheets(newnam).Cells(i + 1, j + 1).Value = Indexer(rng.Cells(i + 1, j + 1).Value, tots(i, 1))
    Next
Next

Range(rng.Cells(1, 1), rng.Cells(1, ncol)).Copy
Worksheets(newnam).Range(Cells(1, 1), Cells(1, ncol)).PasteSpecial (xlPasteValues)

Range(rng.Cells(1, 1), rng.Cells(nrow, 1)).Copy
Worksheets(newnam).Range(Cells(1, 1), Cells(nrow, 1)).PasteSpecial (xlPasteValues)

End Sub

Function Indexer(X, Total) As Long

Indexer = X / Total * 100

End Function