CODEWITHSUNDEEP
excelvbacopy-paste
Nicholas
Nicholas

Reputation: 93

Excel VBA code to copy/paste(transpose) a varying range of values in a loop into a different sheet

I have a (for me) rather complicated task to do in excel. I would like to copy a range of values (transposed) into another sheet. The Values range from 1 to 99 and are always in ascending order.

The task would be to have a VBA, which allows me to populate this sheet with the information I need and it repeats it on a loop until all values are filled in. With this I want to convert a sheet with close to a million rows into one with ca. 25000 rows and ca. 100 columns. Please see the screenshots of what I want to do.

The first picture is the data table (sheet 1). I want to copy the range of values in column C into the proper place in sheet 2. Every time the name changes (and the values start at the low end again), a new row is started in sheet 2.

Maybe it helps that I always know how long the range is, because I know in how many samples this Name appears (1-99), so I know that the range would be e.g. C2:C6 (because this name is in 5 samples), then C7:11 (again 5 samples) etc.

Maybe you can help me with this? I was not able to do it alone.

Image 1:

enter image description here

Image 2:

enter image description here

Upvotes: 0

Views: 1358

Answers (1)

user7168530
user7168530

Reputation:

I had almost exactly the same problem as this once (with mine, I needed to concatenate the values into a single text string as opposed to individual cells!)

Its not as easy to do in excel as it should be I think. My solution is below :)

Sub TransP()

Dim LastRow As Integer
Dim LastCol As Integer

LastRow = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
LastCol = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column

'Clear cells from sheet2

Worksheets("Sheet2").Select

Cells.Select
Selection.ClearContents

'Copy full range from sheet 1

Worksheets("Sheet1").Select

Worksheets("Sheet1").Range(Cells(1, 1), Cells(LastRow, LastCol)).Select
Selection.Copy

'Paste into sheet 2

Worksheets("Sheet2").Select
ActiveSheet.Paste

LastRow = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row

'Iteration to transpose and collate data together

For i = 2 To LastRow

    If Cells(i, 2).Value = Cells(i + 1, 2).Value Then

        LastCol = Worksheets("Sheet2").Cells(i, Columns.Count).End(xlToLeft).Column

        Cells(i, LastCol + 1).Value = Cells(i + 1, 3).Value

        Rows(i + 1 & ":" & i + 1).Select

        Selection.Delete Shift:=xlUp

        i = i - 1

    End If

'Exit sub when it reaches the end (blank cell)

    If Cells(i, 2).Value = "" Or Cells(i + 1, 2).Value = "" Then

        Exit Sub

    End If

Next

End Sub

Upvotes: 1

Related Questions