I have a data file with one column and several rows (dynamic list). I want to transpose the first 28 rows to the first row, the second 28 rows to the second row and so on. I want this to run till an empty row is found. However when i run the code it only transposes the first 28 rows. I have not been able to get results with the "do until empty" loop and am unable to spot the error.
Thanks for your help.
Sub Macro1()
'
' Macro1 Macro
'
'
Range("A1").Select
Do
Range("A1:A28").Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""
End Sub
The macro recorder won't do the loop for you. You do need to pull the Offset out of the loop. Otherwise, fully qualify it:
UPDATE
Option Explicit
Sub CopyPaste()
Dim CopySheet As Worksheet
Dim PasteSheet As Worksheet
Dim MyRange As Range
Dim i As Long
Dim r As Long
Dim wf As WorksheetFunction
Application.ScreenUpdating = False
Set wf = Application.WorksheetFunction
Set CopySheet = ActiveWorkbook.Worksheets("Sheet1")
Set PasteSheet = ActiveWorkbook.Worksheets("Sheet2")
Set MyRange = CopySheet.Range("A1:A28")
r = MyRange.Rows.Count
i = 1
Do Until wf.CountA(MyRange) = 0
MyRange.Copy
PasteSheet.Cells(i, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Set MyRange = MyRange.Offset(r, 0)
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub
Related
EDITED
I would like to ask you for help & revision of my VBA code as I am new to VBA.
I have pivot table with 3 columns. Via slicer I choose the items I want to add in new data table, each item must be added 3 times - therefore in the code I used loop 3 times.
The VBA works perfectly when 2 or more items are chosen.
However, when only single item is selected, the VBA crashes because the "selected copied range" does not have the same size as "pasted range" size. Basically, it selects all cells from column "F2:H2" until the end of spreadsheet.
Sub Copy()
Dim i
For i = 1 To 3
StartRange = "F2:H2"
EndRange = "F2:H2"
Set a = Range(StartRange, Range(StartRange).End(xlDown))
Set b = Range(EndRange, Range(EndRange).End(xlDown))
Union(a, b).Select
Selection.Copy
lastrow = ActiveSheet.Cells(Rows.Count, "T").End(xlUp).Row + 1
Cells(lastrow, "T").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
How to modify the code, if only single item is selected, it will copy the cells in new data table as well?
I can provide a test file for reference.
Use .End(xlDown) from the header row.
Option Explicit
Sub Copy()
Dim ws As Worksheet, rng As Range
Dim i As Long, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
For i = 1 To 3
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).Row + 1
rng.Copy
ws.Cells(lastrow, "T").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
or to copy single rows
Sub Copy2()
Const REPEAT = 3
Dim ws As Worksheet, rng As Range
Dim row As Range, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).row + 1
For Each row In rng.Rows
If Not row.Hidden Then
ws.Cells(lastrow, "T").Resize(REPEAT, row.Columns.Count).Value = row.Value
lastrow = lastrow + REPEAT
End If
Next
End Sub
Here is the code that works to copy Z4:Z11 and then paste it in a row. However when I run it again it just paste over the current data, I want to run it down to the next row.
Sub SaveLineup()
'
' SaveLineup Macro
'
'
Range("Z4:Z11").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A3").Select
Sheets("Sheet1").Select
Application.CutCopyMode = False
Range("Z13").Select
End Sub
Try this:
Option Explicit
Sub Test()
Dim sht As Worksheet, sht2 As Worksheet, lastrow As Long
Set sht = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
lastrow = sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Row + 1
sht2.Range(sht2.Cells(lastrow, 1), sht2.Cells(lastrow + 7, 1)).Value = _
sht.Range(sht.Cells(4, 26), sht.Cells(11, 26)).Value
End Sub
You can avoid using Select by transposing the values from Z4:Z11 into columns A:H.
Find the next blank row each time the routine is run through.
Sub SaveLineup()
Dim nr As Long
With Worksheets("sheet3")
nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
With .Range("Z4:Z11")
.Parent.Cells(nr, "A").Resize(.Columns.Count, .Rows.Count) = _
Application.Transpose(.Value)
End With
End With
End Sub
A Fast Transpose
Sub TransposeColumn()
Const cSource As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cTarget As Variant = "Sheet2" ' Target Worksheet Name /Index
Const cRange As String = "Z4:Z11" ' Source Range
Const cColumn As String = "A" ' Target Column
Dim vntRange As Variant ' Source Array
' Paste Source Range into Source Array.
vntRange = Worksheets(cSource).Range(cRange)
With Worksheets(cTarget)
' Resize the cell below the calculated last row in Target Column by
' the size of Source Array for transposing i.e. the array contains rows,
' but resize by column and paste the Source Array into the resulting
' Target Range.
.Cells(.Cells(.Rows.Count, cColumn).End(xlUp).Row + 1, cColumn) _
.Resize(, UBound(vntRange)) = vntRange
End With
End Sub
I wrote a macro (mostly by recording it) that copies data from a section on one sheet then calculates the end of my table on another sheet and pastes (paste special, being that the data I am pasting is a formula and I need to paste the values) the data to the end of my table, which on its own increases the size of my table.
That works.
My problem is that I am not sure how much of my original range of data (that I am copying) will actually have values in it (there is a formula that is either giving it a value or ""), so I take a large range, just in case
So.... after I pasted it I would like to go through my table and remove any rows that were added that only had empty strings ("") and no values, and then resize the table so it is only as large as the rows that have data.
These rows can be in the middle or at the end of my pasted data.
I need help on the VBA code to do that.
I may also need to clear the formatting that the table automatically added to those additional rows
here is the code I have until now
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Probably best to only place data into the table if its valid, rather than clean up after the paste.
Something like this
Sub Demo()
Dim rDest As Range
Dim lo As ListObject
Dim wsSrc As Worksheet
Dim rSrc As Variant
Dim i As Long
Dim rng As Range
'there are better ways to get a reference to the source data, but thats not the Q here
Set wsSrc = ActiveSheet
Set rSrc = wsSrc.Range("O7:R30")
' destination sheet
With Sheets("deposits")
'get reference to table
Set lo = .ListObjects("deposits")
'Get reference to first row after the table
Set rDest = lo.DataBodyRange.Rows(lo.DataBodyRange.Rows.Count + 1)
i = 0
'loop thru source data rows
For Each rng In rSrc.Rows
'if a row has data
If Application.WorksheetFunction.CountA(rng) > 0 Then
'copy values into table
rDest.Offset(i).Value = rng.Value
i = i + 1
End If
Next
End With
End Sub
This code worked, not elegant, but it worked
Sub copyToDeposits()
Dim theSheet As String
theSheet = ActiveSheet.Name
Application.ScreenUpdating = False
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim lo As ListObject
Dim lRow As ListRow
Dim rng As Range
Dim delRows As Collection
Set lo = ActiveSheet.ListObjects("deposits") 'change to your table name
On Error Resume Next
For Each lRow In lo.ListRows
Set rng = Nothing
Set rng = lRow.Range.Cells(1, 2)
If Not rng Is Nothing Then
If rng = "" Then
If delRows Is Nothing Then
Set delRows = New Collection
delRows.Add lRow
Else
delRows.Add lRow, Before:=1
End If
End If
End If
Next
On Error GoTo 0
If Not delRows Is Nothing Then
For Each lRow In delRows
lRow.Delete
Next
End If
Sheets(theSheet).Select
Application.ScreenUpdating = True
End Sub
i've got a question.
I've got the names of sheets in my workbook in a sheet named "Summary". I've got some stats in a sheet called "Stats". I wanna loop over the names in summary sheet, select each sheet, then copy the values from B2:M2 from "stats" page, transpose copy it to column D2 in the sheet selected from "Summary" sheet. Then I want to move to next sheet from the list of sheets from "Summary" page, copy B3:M3 & copy as transpose the D2 column in the selected sheet & so forth.
I've managed to get this bit of code for it. It's not compelte. I'm unable to figure out how to increment from B2:M2 to B3:M3 to B4:M4 & so on.
Please can someone help me. I've never written VB code before.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim row_counter As Long, col_counter As Long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
row_counter = 2
col_counter = 2
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
row_counter = row_counter + 1
col_counter = col_counter + 1
Next MyCell
End Sub
See below code (which is your code with the addition of offset).
Offset will let you increment from B2:M2 to B3:M3 asb so on.
I replaced your row and col variable with just x since you only move by row.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim x as long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
x = 0
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Offset(x, 0).Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
x = x + 1
Next MyCell
End Sub
Also you can try this:
Dim MyCell, MyRange as Range
Dim wb as Workbook
Dim ws, wsTemp, wsStat as Worksheet
Dim x as Long
Set wb = Thisworkbook
Set ws = wb.Sheets("Summary")
Set wsStat = wb.Sheets("Stats")
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set MyRange = .Range("A1:A" & lrow)
End With
x = 0
For Each MyCell in MyRange
Set wsTemp = wb.Sheets(MyCell.Value)
wsStat.Range("B2:M2").Offset(x, 0).Copy
wsTemp.Range("D2").PasteSpecial xlPasteAll, , , True
x = x + 1
Set wsTemp = Nothing
Next MyCell
End Sub
Already Tested.
Hope it does what you want to achieve.
I have an ActiveSheet script, in where I take raw data move the data to rows Q:V. I have a VBA script that runs and shows where the last row is, in this case the last row is 77.
lastrow = .Cells(.Rows.Count, "Q").End(xlUp).Row
I want to have it where it takes from Q to V last row, copy, and paste it into sheet 1...
I am guessing it will look like this, but I want to verify here first... since my normal sites I go to are down for maintenance for some reason.
Sub test()
Dim wsPOD As Worksheet
Dim wsPOT As Worksheet
Dim wsPOA As Worksheet
Dim cel As Range
Dim lastrow As Long, i As Long, Er As Long
Set wsPOD = Sheets("PO Data")
Set wsPOT = Sheets("PO Tracking")
Set wsPOA = Sheets("PO Archive")
With ActiveSheet
.AutoFilterMode = False
Intersect(.UsedRange, .Columns("A")).Cut .Range("Q1")
Intersect(.UsedRange, .Columns("D")).Cut .Range("R1")
Intersect(.UsedRange, .Columns("C")).Cut .Range("S1")
Intersect(.UsedRange, .Columns("B")).Cut .Range("T1")
Intersect(.UsedRange, .Columns("G")).Cut .Range("U1")
Intersect(.UsedRange, .Columns("F")).Cut .Range("V1")
lastrow = .Cells(.Rows.Count, "N").End(xlUp).Row
Intersect (.UsedRange.Range("Q:V" & lastrow).Copy)
Intersect (wsPOT.Range("B3:H" & lastrow).PasteSpecialxlPasteFormats)
End With
End Sub
This obviously doesn't work, if someone can help me it be appreciated.
Is this what you are trying>
With ActiveSheet
.AutoFilterMode = False
'
'~~> Rest of the code
'
lastRow = .Range("N" & Rows.Count).End(xlUp).Row
.Range("Q1:V" & lastRow).Copy
wsPOT.Range("B3").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
xlPasteFormats will only paste the formats and not the value. If you want to paste value then change xlPasteFormats to xlPasteValues
Option Explicit
Sub copylocation()
Dim EC As Long
Dim X As Long
Dim Y As Long
X = Range("B1").End(xlUp).Offset(1, 0).Row
EC = Range("b1").End(xlToLeft).Offset(0, X).Column
Windows("Book2").Activate
Range("b1:AB" & EC).Select
Selection.Copy
Windows("Book1").Activate
Range("b1").Select
ActiveSheet.Paste
End Sub