Inserting/Copy rows, Transpose vba HELP [Solved/Closed]

cswiss - Jun 15, 2011 at 05:48 PM - Latest reply: shameem007 3 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







See more 

9 replies

Best answer
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Jun 15, 2011 at 08:24 PM
3
Thank you
Could you post a sample book on some shared site and post back the link to the file back here.

Thank you, rizvisa1 3

Something to say? Add comment

CCM has helped 1831 users this month

thanks again
i tried uploading the link here but it wont let me
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Jun 16, 2011 at 04:50 PM
cswiss,: if Wikisend is not working for you, just upload to any google documents or some other shared site and post back link
0
Thank you
thanks
0
Thank you
link please add w w w

4shared.com/file/ApaxULls/Sample_Worksheet.html
Ambucias 55102 Posts Monday February 1, 2010Registration dateModeratorStatus September 24, 2018 Last seen - Jun 17, 2011 at 05:34 AM
Please, in the future use the following for uploading files

http://www.speedyshare.com

Moderator
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Jun 17, 2011 at 01:02 PM
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


shameem007 3 Posts Monday June 20, 2011Registration date June 23, 2011 Last seen - Jun 23, 2011 at 01:04 AM
0
Thank you
thanks