Related:
- How to copy the Column value into Rows
- Excel vba find first empty column in a row - How-To - Excel
- Excel vba find value in column and copy row ✓ - Forum - Office Software
- How to convert column data to row in notepad++ ✓ - Forum - Excel
- How to duplicate rows based on cell value in a column in excel ✓ - Forum - Excel
- How to copy rows if column contains specific text/value in excel? ✓ - Forum - Excel
1 reply
TrowaD
- Posts
- 2675
- Registration date
- Sunday September 12, 2010
- Status
- Moderator
- Last seen
- November 5, 2020
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):
Best regards,
Trowa
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
Subscribe To Our Newsletter!
- Posts
-
21
- Registration date
- Wednesday August 26, 2020
- Status
- Member
- Last seen
- October 13, 2020
> TrowaDPlease 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 > Raj_1562That 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 SubBest regards,
Trowa
- Posts
-
21
- Registration date
- Wednesday August 26, 2020
- Status
- Member
- Last seen
- October 13, 2020
> TrowaDWoW 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 > Raj_1562When 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 SubBest regards,
Trowa
- Posts
-
21
- Registration date
- Wednesday August 26, 2020
- Status
- Member
- Last seen
- October 13, 2020
> TrowaDThank you for helping me out. Greatly appreciate it.