How to copy the Column value into Rows [Solved]

Report
Posts
21
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
October 13, 2020
-
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 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

1 reply

Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
448
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

2
Thank you

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

CCM 2942 users have said thank you to us this month

Posts
21
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
October 13, 2020
>
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020

Hi Trowa,

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

Thanks
Raj
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
448 >
Posts
21
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
October 13, 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
Posts
21
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
October 13, 2020
>
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 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
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
448 >
Posts
21
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
October 13, 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
Posts
21
Registration date
Wednesday August 26, 2020
Status
Member
Last seen
October 13, 2020
>
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020

Hi Trowa,

Thank you for helping me out. Greatly appreciate it.

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!