Inserting/Copy rows, Transpose vba HELP
Solved/Closed
cswiss
-
Jun 15, 2011 at 05:48 PM
shameem007
shameem007
- Posts
- 3
- Registration date
- Monday June 20, 2011
- Status
- Member
- Last seen
- June 23, 2011
Related:
- Inserting/Copy rows, Transpose vba HELP
- Excel vba insert multiple rows - Guide
- Insert 2 rows, copy the formula.VBA HELP Pls ✓ - Forum - Excel
- Insert blank row when value changes in excel using vba ✓ - Forum - Excel
- Excel vba insert multiple rows based on cell value - Forum - Excel
- Insert multiple rows in excel vba - Forum - Excel
4 replies
rizvisa1
Jun 15, 2011 at 08:24 PM
- Posts
- 4479
- Registration date
- Thursday January 28, 2010
- Status
- Contributor
- Last seen
- May 5, 2022
Jun 15, 2011 at 08:24 PM
Could you post a sample book on some shared site and post back the link to the file back here.
link please add w w w
4shared.com/file/ApaxULls/Sample_Worksheet.html
4shared.com/file/ApaxULls/Sample_Worksheet.html
Ambucias
Jun 17, 2011 at 05:34 AM
- Posts
- 47363
- Registration date
- Monday February 1, 2010
- Status
- Moderator
- Last seen
- September 1, 2021
Jun 17, 2011 at 05:34 AM
rizvisa1
Jun 17, 2011 at 01:02 PM
- Posts
- 4479
- Registration date
- Thursday January 28, 2010
- Status
- Contributor
- Last seen
- May 5, 2022
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
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
Jun 23, 2011 at 01:04 AM
- Posts
- 3
- Registration date
- Monday June 20, 2011
- Status
- Member
- Last seen
- June 23, 2011
Jun 23, 2011 at 01:04 AM
thanks
Jun 16, 2011 at 12:20 PM
Jun 16, 2011 at 03:46 PM
Jun 16, 2011 at 04:50 PM