VBA HELP FOR TRANSPOSE PASTING

[eenginar]

Hello,

I have a document with over 1000 rows. I want to copy yellow areas ( Which has "1" value in the "A" Column. and and it will copy the columns until "MISC" word)
and paste them to another sheet as transposed. I need a VBA code which includes a loop.

I will be glad for your help.

 

[DanteAmor]

Hi and welcome to MrExcel

You can put an image with the expected result.

 

[eenginar]

Thank you for replying.

Result should be as follows.

 

[alansidman]

can be accomplished using Power Query and employing the unpivot function.

 

[eenginar]

Actually, i started to learn VBA today thank you, i will watch and try to do it.

 

[Peter_SSs]

Welcome to the MrExcel board!

In your first image all the yellow sections have "1" in column A as you described. However, the non-yellow row rows are inconsistent in column A. for example, rows 10:14 have a "0" but rows 20:23 are empty. Is that actually the case or a mistake with the sample?
Are the values in column A the results of formulas or manually entered?
Are the yellow cells in your sample actually yellow in your file too or was that just to show us?
Are all the yellow sections exactly 5 rows like the two full ones shown?

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

 

[eenginar]

Welcome to the MrExcel board!

In your first image all the yellow sections have "1" in column A as you described. However, the non-yellow row rows are inconsistent in column A. for example, rows 10:14 have a "0" but rows 20:23 are empty. Is that actually the case or a mistake with the sample?
Are the values in column A the results of formulas or manually entered?
Are the yellow cells in your sample actually yellow in your file too or was that just to show us?

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

They are manually entered. I should copy only the rows which have "1" in Column A .
If the value is different than 1, those rows should not be included.

 

[Peter_SSs]

They are manually entered

Thanks.

What about my 3 other questions?

the non-yellow row rows are inconsistent in column A. for example, rows 10:14 have a "0" but rows 20:23 are empty. Is that actually the case or a mistake with the sample?

Are the yellow cells in your sample actually yellow in your file too or was that just to show us?
Are all the yellow sections exactly 5 rows like the two full ones shown?

 

[eenginar]

Welcome to the MrExcel board!

In your first image all the yellow sections have "1" in column A as you described. However, the non-yellow row rows are inconsistent in column A. for example, rows 10:14 have a "0" but rows 20:23 are empty. Is that actually the case or a mistake with the sample? IT WAS MISTAKE, THERE SHOULD BE NO NUMBER OTHER THAN "1" , HOWEVER THE FIRST ROW OF EACH YELLOW TABLE CAN BE A DIFFERENT NUMBER IF IT PROVIDES EASYNESS.
Are the values in column A the results of formulas or manually entered? YES
Are the yellow cells in your sample actually yellow in your file too or was that just to show us? IT WAS DONE BY MANUALLY TO SHOW YOU
Are all the yellow sections exactly 5 rows like the two full ones shown? NO, THERE ARE TABLES UP TO 54 ROWS, SO THEY ARE MIXED

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

 

[Peter_SSs]

Thanks.
The following suggestion is based on ..
- the original data being in Sheet1
- first possible row to copy is row 5
- results to go on Sheet2.
- Sheet 2 already exists.

Test in a copy of your workbook.

Sub FindAndTranspose()
  Dim rFound As Range, rA As Range
  Dim MISCcol As Long
  
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    .Columns("A").AutoFilter Field:=1, Criteria1:="1"
    Set rFound = .Range("A5", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlVisible)
    .AutoFilterMode = False
    For Each rA In rFound.Areas
      MISCcol = .Rows(rA.Row).Find(What:="MISC", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
      Intersect(rA.EntireRow, .Columns("B").Resize(, MISCcol - 1)).Copy
      Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(2).PasteSpecial Transpose:=True
    Next rA
    Application.CutCopyMode = False
  End With
  Application.ScreenUpdating = True
End Sub