Transpose with condition

Pompom66

New Member
Joined
Dec 5, 2016
Messages
3
Good day everyone,

This code was posted some time ago, code that I have modified but, it does not work like I would it to work. Here is what I am trying to achieve.

I want to transpose infos located in Column B1 up to the last cell not empty (in this case, Cell B596), into cell D2, E2, F2, etc.. There could be up to 87 fields to fill.

In column A, I have formulas stating : If B1 = "Mise en situation", enter 1, if not enter 2. Every time 1 is entered, it is the beginning of a groupe of cells in B to be transpose in column D, E F G, etc. starting at D2.

When the next number 1 appears, It will be the beginning of a new groupe of cells to be transposed. Her is an example of what I am trying to achieve. Please note that in column B, I can have 2,000 to 3,000 cells with infos.

Ex. :
IF A1 = 1, D2 = B1
IF A2 = 2, E2 = B2
IF A3 = 2, F2 = B3
IF A4 = 1, D3 = B4
IF A5 = 2, E3 = B5
IF A6 = 2, F3 = B6
IF A7 = 2, G3 = B7
IF A8 = 1, D4 = B8
Etc.

My code :
Code:
Sub Transpose()
'
    Dim ShAsWorksheet
    Dim Rng As Range
    
    Dim r As Long
    Dim c As Integer
    Dim Cell As Range
    Set Sh = Worksheets("InfosWord")
    Set Rng = Sh.Range("A1:A" & Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row)
        r = 1
        c = 2
    For Each Cell In Rng
        Cells(r, c).Value = Cell.Offset(2, 4).Value
    With Rng
    If Cell.Value <> Cell.Offset(1, 2).Value Then
    Cells(r, 1).Value = Cell.Value
    r = r + 1
    c = 2
    Else
    c = c + 1
    
    End If
    End With
    
Next
End Sub

Tks for your help regarding my request,


Daniel

Windows 10, Excel 2016
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
I am not sure I fully understand it, but you can try this and see if it gives you what you want. Requires some editing for sheet name.

Code:
Sub xposeB()
Dim c As Range, i As Long, j As Long, sh As Worksheet
Set sh = Sheets(1)
    i = 1
With sh
    For Each c In .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
        If c = 1 Then
            i = i + 1
            j = 4
            .Cells(i, j) = c.Offset(, 1).Value
            j = j + 1
        Else
            .Cells(i, j) = c.Offset(, 1).Value
            j = j + 1
        End If        
    Next
End With
End Sub
 
Last edited:
Upvote 0
Another approach; runs faster:
Code:
Sub TWC()
    Set LastCell = Range("A" & Rows.Count).End(xlUp)
    r = 2
    With Range("A1", LastCell)
        Set GrpStart = .Find(1, LastCell, xlValues)
        If Not GrpStart Is Nothing Then
            FirstGrp = GrpStart.Address
            Do
                Set A = GrpStart.Offset(0, 1)
                Set GrpStart = .FindNext(GrpStart)
                If GrpStart.Address <> FirstGrp Then _
                    Set Z = GrpStart.Offset(-1, 1) Else _
                    Set Z = LastCell.Offset(0, 1)
                Range(Cells(r, 4), Cells(r, 4 + Z.Row - A.Row)) = _
                    WorksheetFunction.Transpose(Range(A, Z))
                r = r + 1
            Loop While GrpStart.Address <> FirstGrp
        End If
    End With
End Sub
 
Upvote 0
Good day JLGWhiz,

Your code works perfectly. Can you please tell me witch forum to use for further posting?

I am french, my English writing might not be perfect. Sorry about that.

Thank you for your help.

Daniel
 
Upvote 0
Good day JLGWhiz,

Your code works perfectly. Can you please tell me witch forum to use for further posting?

I am french, my English writing might not be perfect. Sorry about that.

Thank you for your help.

Daniel
I believe your English is good enough for this forum, but there if you want to try it, there is one you can access by clicking on the quick access, then click 'Questions in Other Languages'. Like I said, your English is as good as some of us who call it our first language, but you decide.
Regards, JLG
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,954
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top