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 :
Tks for your help regarding my request,
Daniel
Windows 10, Excel 2016
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