Menu
  1. Accueil
  2. Tech Forum
  3. Office Software
  4. Excel

How to copy the Column value into Rows [Solved]

Report
Posts
12
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
September 14, 2020
 -
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
 -
Dear Experts,

I would like to copy the team name according to the image shown below.

For your reference i differentiate 3 combination but I would like to display 3 combination in one single



Thanks in advance!

Regards,
Raj
See more

1 reply

Answer 1 / 1
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
 439
Hi Raj,

I made an addition to the code I posted last time (https://ccm.net/forum/affich-1118956-auto-generate-serial-number-in-excel-based-on-input-value): 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim mStep, NoR, x, y As Integer
If Intersect(Target, Range("G3")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False

mStep = WorksheetFunction.CountA(Range("C3:E3"))
NoR = Target.Value
x = 6

Range("A6:C" & Rows.Count).ClearContents

For y = NoR To 1 Step -1
    Range("C3:E3").Copy
    Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next y

Do
    y = y + 1
    Cells(x, "A").Value = y
    x = x + mStep
    NoR = NoR - 1
Loop Until NoR = 0

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


Best regards,
Trowa

Comment
Thank you
2
Thank you

Glad we were able to help! Love us? Write us a review! Rate CCM

CCM 2818 users have said thank you to us this month

View all 8 comments
Report
Posts
12
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
September 14, 2020
 >
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
Hi Trowa,

Please find the file link : https://we.tl/t-eZCR7SNRM2

Thanks
Raj
Report
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
 439 >
Posts
12
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
September 14, 2020
Hi Raj,

That one worked. Here is the adjusted code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim mStep, NoR, x, y, rID As Integer

If Intersect(Target, Range("K3")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False

mStep = WorksheetFunction.CountA(Range("H3:J3"))
NoR = Target.Value
rID = Range("E5").Value
x = 9

Range("B9:C" & Rows.Count).ClearContents
Range("H9:H" & Rows.Count).ClearContents

For y = NoR To 1 Step -1
    Range("H3:J3").Copy
    Range("H343").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
Next y

Do
    y = y + 1
    Cells(x, "B").Value = y
    Cells(x, "C").Value = rID
    x = x + mStep
    NoR = NoR - 1
Loop Until NoR = 0

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


Best regards,
Trowa
Report
Posts
12
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
September 14, 2020
 >
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
Hi Trowa,

WoW Amazing!

It's work perfect!

And I have one doubt! While copy the teams from sheet 2 to sheet 1 using =TRANSPOSE(Sheet2!A2:A4) functionality.i got one empty space. if in sheet 2 only one teams will available i got 2 empty space.Do you have any idea to overcome that issue.



Thanks in advance!

Regards,
Raj
Report
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
 439 >
Posts
12
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
September 14, 2020
Hi Raj,

When using the transpose function you should be getting a 0 for empty values. Yours doesn't show anything. I can replicate your sheet in 2 ways. By entering an apostrophe in the empty cell(s) on sheet2 or by adding a conditional formatting rule on sheet1 to give a 0 a white colored text. The adjusted code below counts the cells in range A2:A4 on Sheet2 which contain text. An apostrophe is considered text. Maybe you used a different way to get (an) empty cell(s) on Sheet1 as long as the teams on Sheet2 contain either a team name or are empty then the code performs as expected.

Here is the code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim mStep, NoR, x, y, rID As Integer

If Intersect(Target, Range("K3")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False

mStep = WorksheetFunction.CountIf(Sheets("Sheet2").Range("A2:A4"), "*")
NoR = Target.Value
rID = Range("E5").Value
x = 9

Range("B9:C" & Rows.Count).ClearContents
Range("H9:H" & Rows.Count).ClearContents

For y = NoR To 1 Step -1
    Sheets("Sheet2").Range("A2:A4").Copy
    Range("H343").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Next y

Do
    y = y + 1
    Cells(x, "B").Value = y
    Cells(x, "C").Value = rID
    x = x + mStep
    NoR = NoR - 1
Loop Until NoR = 0

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


Best regards,
Trowa
Report
Posts
12
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
September 14, 2020
 >
Posts
2654
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 14, 2020
Hi Trowa,

Thank you for helping me out. Greatly appreciate it.
Reply Ask a question