I can't figure this out.
Sub Paste1()
Dim NextRow As Range
Set NextRow = Range("A" & Sheets("AMCurrent").UsedRange.Rows.Count + 1)
AMPaste.Range("A3:F3").Copy
AMCurrent.Activate
NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = False
Set NextRow = Nothing
End Sub
I get an "object error" on row 4, AMPaste.Range("A3:F3").Copy.
I'm assuming you didn't declare your Worksheets, and that you used their name instead of Sheets("SheetName"), but I believe this could be your solution:
Sub Paste1()
Dim NextRow As Long
Dim wsPaste As Worksheet: Set wsPaste = Sheets("AMPaste")
Dim wsCurrent As Worksheet: Set wsCurrent = Sheets("AMCurrent")
NextRow = wsCurrent.Cells(wsCurrent.Rows.Count, "A").End(xlUp).Row + 1
wsPaste.Range("A3:F3").Copy
wsCurrent.Range("A" & NextRow).PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = False
End Sub
I had the same problem. My worksheet was named "tagsListSheet" and in my script I had a Worksheet variable also named "tagsListSheet". My line of code that produced your error looked like:
Set wwTags = Range(tagsListSheet.Cells(2, 2), tagsListSheet.Cells(lastTagRow, 2))
and when I changed the name of the worksheet variable, it worked.
Set wwTags = Range(tagSheet.Cells(2, 2), tagSheet.Cells(lastTagRow, 2))
Related
I'm trying to run before I can crawl. I have pieced together this code, but I need it to Insert at row 24, not copy.
Dim sh4 As Worksheet, sh5 As Worksheet, lr As Long, rng As Range
Set sh4 = Sheets("est")
Set sh5 = Sheets("gaf letter")
lr = sh4.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh4.Range("a1:a" & lr)
rng.EntireRow.Copy sh5.Rows("24:24")
I've attempted using .Insert, but it comes up with Method Insert of object Range Failed. The code works fine if I wanted to just copy, but I need it to insert and shift the remaining rows below it, down.
Option Explicit ' declare all variables
Sub InsertRows()
Dim sh4 As Worksheet, sh5 As Worksheet
Dim lr As Long, rng As Range
Set sh4 = Sheets("est")
Set sh5 = Sheets("gaf letter")
Application.ScreenUpdating = False
With sh4
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Rows("1:" & lr)
rng.Copy
sh5.Rows(24).Insert shift:=xlDown
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
just go
With Sheets("est")
.Range("A1", .Cells(.rows.Count, 1).End(xlUp)).EntireRow.Copy
Sheets("gaf letter").rows(24).Insert shift:=xlDown
Application.CutCopyMode = False
End With
I am trying to copy & transpose values from one Sheet to another Sheet based on a condition, only transpose the first 4 lines looping in large range.
From this:
To this :
I've found a transpose macro and adapt it but I couldn't apply the condition.
Sub Test()
Set rng = Range("B5", Range("B5").End(xlDown))
Sheets("Example #2").Range(rng).Value = WorksheetFunction.Transpose()
EndSub
Anyone can guide me? Any help would be greatly appreciated!
Please, test the next code. It uses arrays, works in memory and will be much faster than copying. This can be easier observed on a large range:
Sub CopyTranspose4rows()
Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, arr, arrSl, i As Long
Set sh1 = ActiveSheet 'use here the sheet you need to copy from
Set sh2 = sh1.Next 'use here what sheet you need to paste
lastR = sh1.Range("B" & sh1.rows.count).End(xlUp).row 'last row sh1
arr = sh1.Range("B5:B" & lastR).Value 'put the range in an array for fast iteration
For i = 1 To UBound(arr) Step 4 'iterate from four to four
With Application
'create a slice array
arrSl = .Transpose(.Index(arr, Evaluate("row(" & i & ":" & i + 4 & ")"), 1))
End With
'drop the slice array content in the second sheet
sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1).Resize(1, 4).Value = arrSl
Next i
sh2.Activate 'activate the sheet where pasted
End Sub
#FaneDuru's array solution is more elegant, but here's another alternative. You would need to replace the sheet names and the starting cell numbers.
Sub TestTranspose()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LR1 As Long
Dim x As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
LR1 = sht1.Cells(Rows.Count, 2).End(xlUp).Row
y = 1
For x = 1 To LR Step 4
sht1.Range(sht1.Cells(x, 2), sht1.Cells(x + 3, 2)).Copy
sht2.Cells(y, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
y = y + 1
Next x
End Sub
With this code you can have different number of answers per question.
Sub Tranpose_Questions()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim transRng As Range ' range to transpose
Dim dstRng As Range: Set dstRng = ActiveSheet.Range("C1") ' destination cell
' Value find
fnd = "Question"
Set myRange = ActiveSheet.Range("A1", Range("A1").End(xlDown))
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
' Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo errHandler
End If
Set rng = FoundCell
' Loop
Do Until FoundCell Is Nothing
' Find next cell
Set FoundCell = myRange.FindNext(after:=FoundCell)
Debug.Print rng.Address, FoundCell.Address
' Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then
Set transRng = Range(rng, rng.End(xlDown))
If rng.Offset(1, 0) <> "" Then
transRng.Select: transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End If
Exit Do
End If
' Transpose
Set transRng = rng.Resize(FoundCell.Row - rng.Row, 1)
transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
' update rng position
Set rng = FoundCell
' update destination range
Set dstRng = dstRng.Offset(1, 0)
Loop
Exit Sub
' Error Handler
errHandler:
MsgBox "No 'Question' found!"
End Sub
I am getting constant error of "out of range" but the reference of the range is correct, please help me to solve the error: the error or bug in the coding is highlighted as bold in the below mentioned code:
Sub CopyStuff()
**Sheets("Data-BNF").Range("D11:X76").Copy**
Sheets("Storage-OI").Range("C" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
End Sub
Modify the below and try:
Option Explicit
Sub Copy()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long
With ThisWorkbook
Set ws1 = .Worksheets("Data-BNF")
Set ws2 = .Worksheets("Storage-OI")
End With
Lastrow = ws2.Cells(ws2.Rows.Count, "C").End(xlUp).Row
ws1.Range("D11:X76").Copy
'Try the **ONE of the below**
ws2.Range("C" & Lastrow + 1).PasteSpecial Paste:=xlPasteValue
ws2.Range("C" & Lastrow + 1).PasteSpecial xlPasteValues
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