hardeep
06-22-2009, 01:13 AM
H!
I have 2 code. 1 for delete the Duplicate Blanks row in a Column and another one for "TRANSPOSE THE COLUMN INTO ROWS"
Now i want to Combine into 1. Dont want to Run These Macro 1 by 1
Code 1: Delete The Duplicate Blanks Row in a Column
Sub DeleteBlankRows()
'JBeaucaire (12/12/2008)
Dim i As Long, LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = LR To 2 Step -1
If Application.CountA(Cells(i, 1).EntireRow) = 0 And _
Application.CountA(Cells(i - 1, 1).EntireRow) = 0 Then _
Cells(i, 1).EntireRow.Delete
Next i
Application.ScreenUpdating = True
End Sub
Code 2: For Transpose The Column into Rows
Public Sub TransposePersonalData()
'ken johnson July 29, 2006
'transpose uneven sets of data........must have a blank row between
Application.ScreenUpdating = False
Dim rngData As Range
Dim iLastRow As Long
Dim i As Long
Dim iDataColumn As Integer
iDataColumn = Selection.Column
iLastRow = Cells(Application.Rows.Count, iDataColumn).End(xlUp).Row
i = Selection.Row - 1
Do While ActiveCell.Row < iLastRow
i = i + 1
Set rngData = Range(ActiveCell, ActiveCell.End(xlDown))
rngData.Copy
Cells(i, iDataColumn + 1).PasteSpecial Transpose:=True
rngData.Cells(rngData.Cells.Count + 2, 1).Activate
Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thanks in Advance
Hardeep Kanwar
I have 2 code. 1 for delete the Duplicate Blanks row in a Column and another one for "TRANSPOSE THE COLUMN INTO ROWS"
Now i want to Combine into 1. Dont want to Run These Macro 1 by 1
Code 1: Delete The Duplicate Blanks Row in a Column
Sub DeleteBlankRows()
'JBeaucaire (12/12/2008)
Dim i As Long, LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = LR To 2 Step -1
If Application.CountA(Cells(i, 1).EntireRow) = 0 And _
Application.CountA(Cells(i - 1, 1).EntireRow) = 0 Then _
Cells(i, 1).EntireRow.Delete
Next i
Application.ScreenUpdating = True
End Sub
Code 2: For Transpose The Column into Rows
Public Sub TransposePersonalData()
'ken johnson July 29, 2006
'transpose uneven sets of data........must have a blank row between
Application.ScreenUpdating = False
Dim rngData As Range
Dim iLastRow As Long
Dim i As Long
Dim iDataColumn As Integer
iDataColumn = Selection.Column
iLastRow = Cells(Application.Rows.Count, iDataColumn).End(xlUp).Row
i = Selection.Row - 1
Do While ActiveCell.Row < iLastRow
i = i + 1
Set rngData = Range(ActiveCell, ActiveCell.End(xlDown))
rngData.Copy
Cells(i, iDataColumn + 1).PasteSpecial Transpose:=True
rngData.Cells(rngData.Cells.Count + 2, 1).Activate
Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thanks in Advance
Hardeep Kanwar