[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
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