Trying to move data in contigious way .
Columns A shows Headers at row 8 and 9.
At row 38 shows page no .
When the going to next page no there is a difference of 6 and the pattern remains same between page nos.
How to move the actual data of column A in vba to a new sheet (test)in same workbook by transposing the headers to row 1 as well as data with it page numbers.
The data can reach 100 pages as shown in column A
Re: vba to transpose rows headers and data to columns headers with respective data
Hello! Give this a try:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim SheetName As String
Dim lrow As Long
Dim pg As String
Dim i As Long
Dim Counter As Long
Dim pgCounter As Long
Set ws1 = ActiveSheet
SheetName = "Test"
Application.DisplayAlerts = False
On Error Resume Next
Sheets(SheetName).Delete
Application.DisplayAlerts = True
Set ws2 = Sheets.Add
ws2.Name = SheetName
ws2.Cells(1, 1) = "Page"
ws2.Cells(1, 2) = ws1.Cells(8, 1)
ws2.Cells(1, 3) = ws1.Cells(9, 1)
lrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Counter = 2
pgCounter = 2
For i = 10 To lrow Step 2
ws2.Cells(Counter, 2) = ws1.Cells(i, 1)
ws2.Cells(Counter, 3) = ws1.Cells(i + 1, 1)
If InStr(ws1.Cells(i, 1), "Page") > 0 Then
pg = Right(ws1.Cells(i, 1), 1)
ws2.Range(ws2.Cells(pgCounter, 1), Cells(Counter, 1)) = pg
pgCounter = Counter
i = i + 4
Counter = Counter - 1
End If
Counter = Counter + 1
Next i
End SubRe: vba to transpose rows headers and data to columns headers with respective data
An alternative approach.
Click the button on sheet on attached file.
Code assigned to the button
Sub TransposeData()
Dim x, y(), Aria, i As Long, ii As Long, iii As Long, iv As Integer
ReDim Preserve y(1 To 3, 1 To 1)
y(1, 1) = "Page": y(2, 1) = "Item No.": y(3, 1) = "Hs Code"
iii = 1
For i = 2 To Columns(1).SpecialCells(2).Areas.Count
x = Columns(1).SpecialCells(2).Areas(i)
If IsArray(x) Then
If i = 2 Then iv = 5 Else iv = 1
For ii = iv To UBound(x, 1) - 1 Step 2
iii = iii + 1: ReDim Preserve y(1 To 3, 1 To iii)
y(1, iii) = CInt(Split(x(UBound(x), 1))(2))
y(2, iii) = "'" & x(ii, 1): y(3, iii) = x(ii + 1, 1)
Next
End If
Next
Sheets.Add , Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = "Transposed Data"
.[a1].Resize(UBound(y, 2), 3) = Application.Transpose(y)
With .UsedRange.Rows(1)
.Interior.Color = RGB(218, 218, 218)
.Font.Bold = 1
.HorizontalAlignment = -4108
End With
.UsedRange.Columns(1).Resize(, 2).HorizontalAlignment = -4108
End With
End SubRe: vba to transpose rows headers and data to columns headers with respective data
You're welcome.
Re: vba to transpose rows headers and data to columns headers with respective data
Hello KjBox
Trying your code on bigger no of pages getting issues
runtime error 9 script out of range
the word below represents end of report
[TABLE="width: 108"]
[TD="class: xl63, width: 144"]Item Total:[/TD]
[/TABLE]
the pages can reach 200 to 300 pages .
Test on 8 pages was unsuccesful
Could you look in
Re: vba to transpose rows headers and data to columns headers with respective data
That error was due to an inconsistency in your data, for the first 3 pages each section ended with "Page Number: 1" but from page 4 onwards there is no space after the colon ("Page Number:4").
I have modified the code to account for that, also included a Function to transpose the array before placing its contents onto the new sheet because Application.Transpose may fail when your data is mre than 100 pages.
Change the code to this:
Sub TransposeData()
Dim x, y(), z, Aria, i As Long, ii As Long, iii As Long, iv As Integer, lRow As Long
ReDim Preserve y(1 To 3, 1 To 1)
y(1, 1) = "Page": y(2, 1) = "Item No.": y(3, 1) = "Hs Code"
iii = 1
lRow = Application.Match("Item Total:*", Columns(1), 0)
Application.ScreenUpdating = 0
Rows(lRow).Insert
For i = 2 To Columns(1).SpecialCells(2).Areas.Count - 1
x = Columns(1).SpecialCells(2).Areas(i)
If IsArray(x) Then
If i = 2 Then iv = 5 Else iv = 1
For ii = iv To UBound(x, 1) - 1 Step 2
iii = iii + 1: ReDim Preserve y(1 To 3, 1 To iii)
y(1, iii) = CInt(Trim(Split(x(UBound(x), 1), ":")(1)))
y(2, iii) = "'" & x(ii, 1): y(3, iii) = x(ii + 1, 1)
Next
End If
Next
Rows(lRow).Delete
z = TransposeArray(y)
Sheets.Add , Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = "Transposed Data"
.[a1].Resize(UBound(z, 1), 3) = z
With .UsedRange.Rows(1)
.Interior.Color = RGB(218, 218, 218)
.Font.Bold = 1
.HorizontalAlignment = -4108
End With
.UsedRange.Columns(1).Resize(, 2).HorizontalAlignment = -4108
End With
End Sub
Private Function TransposeArray(Arr As Variant) As Variant
Dim temp, a As Long, b As Long, i As Long, ii As Long
i = UBound(Arr, 2): ii = UBound(Arr, 1)
ReDim temp(1 To i, 1 To ii)
For a = 1 To i
For b = 1 To ii
temp(a, b) = Arr(b, a)
Next
Next
TransposeArray = temp
End FunctionRe: vba to transpose rows headers and data to columns headers with respective data
Apologize for this trouble, the code works well , but need a little tuning when there is 0 in front of numbers ,
applying code removes the 0 as below example,
Could you adjust
thanks
QuoteDisplay More[TABLE="width: 125"]
[tr][/tr]
[TD="align: right"]96190040[/TD][tr]
[/tr]
[TD="align: right"]122[/TD][tr]
[td]
05040099
[/td][/tr]
[tr]
[/tr]
[TD="align: right"]123[/TD][tr]
[td]
09012100
[/td][/tr]
[tr]
[/tr]
[TD="align: right"]124[/TD][tr]
[td]
09041100
[/td][/tr]
[tr]
[/tr]
[TD="align: right"]125[/TD]
[/TABLE]
QuoteDisplay More[TABLE="width: 192"]
[tr][/tr]
[TD="class: xl65, width: 64"]8[/TD]
[TD="class: xl65, width: 64"]122[/TD]
[TD="width: 64, align: right"]5040099[/TD][tr]
[/tr]
[TD="class: xl65"]8[/TD]
[TD="class: xl65"]123[/TD]
[TD="align: right"]9012100[/TD][tr]
[/tr]
[TD="class: xl65"]8[/TD]
[TD="class: xl65"]124[/TD]
[TD="align: right"]9041100[/TD]
[/TABLE]
Don’t have an account yet? Register yourself now and be a part of our community!