Inserting/Copy rows, Transpose vba HELP [Solved/Closed]
cswiss -
Jun 15, 2011 at 05:48 PM - Latest reply: shameem0073
Posts Monday June 20, 2011Registration date
June 23, 2011
Last seen
- Jun 23, 2011 at 01:04 AM
Hello,
I have searched through many posts and it appeard everyone is very helpful. My skills in vba are ok but i lack the knowledge to solve my problem...
I have data as follows that i need to transform into singular rows depeding on Col 35 to 45. It looks as follows. I did not include the data because it too long. Please let me know if i need to add more detail. I would like the new data to be populated a new worksheet
Col 1 - 34, Col 35 - 45
DataA 1 - 34, col 35 - 45
DataB 1 - 34, col 35 - 45
.
.
.
n rows, col 35 - 45
becomes...
Col 1 to 35 (empty heading for col 35)
DataA 1 to 34, col 35
DataA 1 to 34, col 36
DataA 1 to 34, col 37
DataA 1 to 34, col 38
DataA 1 to 34, col 39
DataA 1 to 34, col 40
DataA 1 to 34, col 41
DataA 1 to 34, col 42
DataA 1 to 34, col 43
DataA 1 to 34, col 44
DataA 1 to 34, col 45
DataB 1 to 34, col 35
DataB 1 to 34, col 36
DataB 1 to 34, col 37
DataB 1 to 34, col 38
DataB 1 to 34, col 39
DataB 1 to 34, col 40
DataB 1 to 34, col 41
DataB 1 to 34, col 42
DataB 1 to 34, col 43
DataB 1 to 34, col 44
DataB 1 to 34, col 45
.
.
.
n rows
cswiss : Try using macro "doCustomTranspose"
Change the value for stating column and sheet name to reflect real values
Public Sub doCustomTranspose()
Dim iLastHeadCol As Integer
Dim iRepeatFactor As Integer
Dim lLastRow As Long
Dim lRow As Long
Dim sSheet As String
Dim lLastCol As Long
Dim iTranColStart As Long
iLastHeadCol = 35
sSheet = "Sheet1"
lRow = 2
With Sheets(sSheet)
lLastRow = getItemLocation("*", .Cells)
If lLastRow < lRow Then Exit Sub
lLastCol = getItemLocation("*", .Rows(1), , , False)
If (iLastHeadCol >= lLastCol) Then Exit Sub
iRepeatFactor = lLastCol - iLastHeadCol - 1
Application.CutCopyMode = False
iTranColStart = iLastHeadCol + 1
.Columns(iTranColStart).Insert
.Columns(iTranColStart).Insert
iTranColStart = iTranColStart + 2
lLastCol = lLastCol + 2
Do While lLastRow >= lRow
If (iRepeatFactor > 0) _
Then
.Rows(lRow + 1 & ":" & lRow + iRepeatFactor).Insert
lLastRow = lLastRow + iRepeatFactor
Application.CutCopyMode = False
.Range(.Cells(lRow, 1), .Cells(lRow, iLastHeadCol)).Copy
.Range(.Cells(lRow + 1, 1), .Cells(lRow + iRepeatFactor, iLastHeadCol)).PasteSpecial
Application.CutCopyMode = False
End If
.Range(.Cells(1, iTranColStart), .Cells(1, lLastCol)).Copy
.Cells(lRow, iLastHeadCol + 1).PasteSpecial Transpose:=True
.Range(.Cells(lRow, iTranColStart), .Cells(lRow, lLastCol)).Copy
.Cells(lRow, iLastHeadCol + 2).PasteSpecial Transpose:=True
Application.CutCopyMode = False
lRow = lRow + iRepeatFactor
Next_lRow:
lRow = lRow + 1
Loop
.Range(.Cells(1, iTranColStart), .Cells(1, lLastCol)).EntireColumn.Delete
End With
End Sub
Public Function getItemLocation(sLookFor As String, _
rngSearch As Range, _
Optional bFullString As Boolean = True, _
Optional bLastOccurance As Boolean = True, _
Optional bFindRow As Boolean = True) As Long
'find the first/last row/column within a range for a specific string
Dim Cell As Range
Dim iLookAt As Integer
Dim iSearchDir As Integer
Dim iSearchOdr As Integer
If (bFullString) _
Then
iLookAt = xlWhole
Else
iLookAt = xlPart
End If
If (bLastOccurance) _
Then
iSearchDir = xlPrevious
Else
iSearchDir = xlNext
End If
If Not (bFindRow) _
Then
iSearchOdr = xlByColumns
Else
iSearchOdr = xlByRows
End If
With rngSearch
If (bLastOccurance) _
Then
Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
Else
Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
End If
End With
If Cell Is Nothing Then
getItemLocation = 0
ElseIf Not (bFindRow) _
Then
getItemLocation = Cell.Column
Else
getItemLocation = Cell.Row
End If
Set Cell = Nothing
End Function
has helped 1667 users this month