Transpose a multidimensional table into a two dimensional table

Pivot’s are very effective tool in Excel but only if we have data stored in rolling format; where as most of people store data in running tables making it useless for pivots, and often there are times when we need to append this data to some database which makes it critical.

The codes below will help you use a Custom VBA Excel Function to transpose a running table into rolling table the syntax is TransArryaSize(strtRange As Range, cOffset As Variant, endRange As Range)

Paste the code below in standard VBA module try this macro to test the fuction


Sub TestConvertToTranspose()
Call TransArryaSize(Range("E11"), 2, Range("J37"))
' E11 is first cell of table
' 2 are the first two column that will remain as it is
' J37 is last cell of table
End Sub





"************Paste it from hear on in any VBA module***********

Function TransArryaSize(strtRange As Range, cOffset As Variant, endRange As Range)

' Trnaspose Function by Ritwik @ http://ritwik-shukla-vb.blogspot.com

Dim RowCount, ColumnCount As Integer

RowCount = endRange.Row - strtRange.Row
ColumnCount = endRange.Column - strtRange.Column + 1

Range(strtRange.Offset(1, 0), Cells(endRange.Row, strtRange.Column + cOffset - 1)).Copy
Sheets.Add
Range("A2").Select
ActiveSheet.Name = "Trans"


For I = 1 To ColumnCount - cOffset
Sheets("Trans").Cells(65536, 1).Select
Selection.End(xlUp).Offset(1, 0).Select
Call copyColumn

Next I


Application.CutCopyMode = False

Sheets("Data").Activate
Sheets("Data").Cells(strtRange.Row, strtRange.Column + cOffset).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

Sheets("Trans").Activate


For I = 1 To RowCount

Sheets("Trans").Cells(65536, (cOffset + 1)).Select
Selection.End(xlUp).Offset(1, 0).Select
Call copyRow

Next I

Application.CutCopyMode = False

For N = 1 To RowCount

Sheets("Data").Activate
Sheets("Data").Cells(strtRange.Row + N, strtRange.Column + cOffset).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Trans").Activate
Sheets("Trans").Cells(65536, (cOffset + 2)).Select
Selection.End(xlUp).Offset(1, 0).Select
Call copyRow

Next N

End Function

Function copyColumn()
'
' To Copy Column data by mulitiplying
' 3/5/2009 by Ritwik
'

'


Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Function


Function copyRow()
'
' To Copy Row Data into Transpose from Row
' 3/5/2009 by Ritwik
'
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

End Function

Excel-add in for "Collecting Data from Multiple Excel Workbooks into a Single Text File using VBA"

This is a Excel Add-in created with cods I had discussed in "Collecting Data from Multiple Excel Workbooks into a Single Text File using VBScript"

Prompting for a password before running a VBA code

The macro below will help you set a custom password for running a macro in workbook. Let’s say you have a run query button on your worksheet and you want to make sure before running the codes behind this query user needs to be authenticated.


Private Sub CommandButton1_Click()

Dim strPass As String ' This sting is password

Dim lCount As Long

For lCount = 1 To 3

strPass = InputBox(Prompt:="Password Please", Title:="PASSWORD REQUIRED")

If strPass = vbNullString Then 'Cancelled

sLast.Select

Exit Sub

ElseIf strPass <> "Password" Then 'InCorrect password

MsgBox "Password incorrect", vbCritical, "Failed"

Else 'Correct Password

Exit For

End If

Next lCount

If lCount = 4 Then 'They use up their 3 attempts

MsgBox "The password is wrong, workbook is going close", vbInformation

ActiveWorkbook.Close SaveChanges:=False

Exit Sub

Else

MsgBox "Correct Password", vbOKOnly 'put your codes from hear on

End If

End Sub

Extract the RGB colour of a shape using VBA.

There are times when we want to replicate a Shapes RBG value in some other shape or at least know the Red, Green and Blue components distinctly.

Hear is function that will help us extract the RBG value of shape is any MS Office Application (Word, Excel, and PowerPoint).

The function returns two values, one as Text string and the other one as Hexadecimal value depending on the Boolean type you specify.

Paste the codes as below in any VBA mobule:

Function RBGExtract(myShape As Shape, IsHex As Boolean) As Variant c = myShape.Fill.ForeColor.RGB If IsHex = False Then redComponent = c Mod 256 greenComponent = c \ 256 Mod 256 blueComponent = c \ 65536 Mod 256 RBGExtract = "RGB components: " & redComponent & _ ", " & greenComponent & ", " & blueComponent Else RBGExtract = c End If End Function

Now, its time to test the function that we have created, we will test it in PPT through following subroutine:

Sub Test() With ActivePresentation.Slides(1) MsgBox RBGExtract(.Shapes(1), True), vbInformation, 'To test the Hexadecimal value MsgBox RBGExtract(.Shapes(1), False), vbInformation, 'To test the Text value End With End Sub