I am kind of new with VBA and I have a problem I cannot solve and cannot find the right solutions in earlier questions. In fact it looks quite simple. I want to copy a range in worksheet with the name "Blad3" and paste the values in in worksheet with the name "Blad1". This is what I made and where does it go wrong?
ActiveSheet.Cells(dattel, 4).Select
ActiveCell.Range("A1:J1").Copy
Sheets("Blad1").Select
Cells(8 + aantkk, 6).Select
ActiveSheet.Unprotect
' ActiveCell.PasteSpecial xlPasteValues
Selection.PasteSpecial Paste:=xlValue
' ActiveSheet.Paste
ActiveSheet.Protect
First, the real answer to your dilemma is to protect the worksheet with the UserInterfaceOnly:=True parameter so that you do not have to Unprotect it to write values using VBA code.
Run this once.
sub protectBlad1FromUser()
worksheets("Blad1").unprotect
worksheets("Blad1").protect UserInterfaceOnly:=True
end sub
Now you can do anything you want to the Blad1 worksheet in VBA while protecting it from the user.
As to your original code, it is confusing. If .Cells(dattel, 4) is D4 on the Blad3 worksheet then ActiveCell.Range("A1:J1").Copy doesn't copy A1:J1; it copies D4:M4. In any event, direct value transfer is a more efficient method of transferring values than Copy, Paste Special, Values.
dim rng as range
set rng = worksheets("blad3").cells(dattel, 4).resize(1, 10) '<~~ figure out what this is supposed to be
with worksheets("Blad1")
.cells(8 + aantkk, 6).resize(rng.rows.count, rng.columns.count) = rng.value
end with
Would this work for you?
Sheets("Blad3").Range("A1:J1").Copy
Sheets("Blad1").Range("A1:J1").PasteSpecial Paste:=xlValue
I tested it on a new workbook and it seemed to work just fine.
May be try this
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim rng As Range
Set srcSht = ThisWorkbook.Sheets("Blad3") 'this is source sheet
Set destSht = ThisWorkbook.Sheets("Blad1") 'this is destination sheet
With destSht
.Unprotect 'unprotect sheet Blad1
Set rng = srcSht.Range("A1:J1") 'set range to copy
.Cells(8 + aantkk, 6).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 'paste only values
.Protect 'protect sheet Blad1
End With
End Sub
SELECT and ACTIVATE should be avoided. See this for details.
Related
I would like to copy a range in one sheet and paste it as a value in another sheet, but just in a specific range in the next available cell in column B. Starting from B4 to B23 only.
I changed some code I found online but it's not working for me in finding the next available row. After I run the macro the first time, when I run it again and again it does nothing, and it's not working in pasting only the values either.
I tried saving the file before running the Macro again, but still it's not working.
At the end, when the range in the Print sheet is full, I would like a message box asking me to select one of the printers (not the default) on one of my servers (specifying the server path in the code like \a_server_name) and print this Print Sheet only, or clear the records in the range in the Print Sheet, or save only the Sheet Print in a new file (SaveAs) to a location I can choose on one of my servers (specifying the server path in the code \a_server_name) or simply do nothing and end the sub.
Thank you.
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets(“Data”)
Set pasteSheet = Worksheets("Print”)
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B4:I23").End(xlUp).Offset(1,0)
.PasteSpecial.xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
This will set the values equal to each other without copying/pasting.
Option Explicit
Sub Testing()
Dim wsC As Worksheet: Set wsC = ThisWorkbook.Sheets("Data")
Dim wsP As Worksheet: Set wsP = ThisWorkbook.Sheets("Print")
Dim LRow As Long
LRow = wsP.Range("B" & wsP.Rows.Count).End(xlUp).Offset(1).Row
wsP.Range("B" & LRow).Resize(wsC.Range("J11:Q11").Rows.Count, wsC.Range("J11:Q11").Columns.Count).Value = wsC.Range("J11:Q11").Value
End Sub
Modifying your code - and reducing to minimal example
Sub test()
Dim copySheet As Worksheet: Set copySheet = Worksheets("Data")
Dim pasteSheet As Worksheet: Set pasteSheet = Worksheets("Print")
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B" & pasteSheet.Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End Sub
From what i can gather, you want to copy 8 cells and paste all 8 cells to 20 rows, starting at B4. You are not clear on how you want to rerun the macro, it will just write over the data you just pasted.
The first code will copy the 8 cells into the 20 rows
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Range("B4:I23").PasteSpecial Paste:=xlPasteValues
End With
This second code uses a for loop to accoplish the same task, but it also will write over the previously pasted data.
Dim i As Long
With ThisWorkbook
For i = 4 To 23
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(i, 2).PasteSpecial Paste:=xlPasteValues
Next i
End With
If you want to be able to reuse the macro, you will have to modify the range to be copied that allows you to select the range you want to copy. Maybe a variable that allows a user input with a InputBox.
Edit:
Dim lRow As Long
lRow = Sheets("Print").Cells(Rows.Count, 2).End(xlUp).Row
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Edit #3
With ThisWorkbook
Dim lRow As Long
lRow = .Sheets("Print").Range("B" & Rows.Count).End(xlUp).Row
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
I need to be able te
Find a value in column A
Select that value and everything above it
Offset all those values over one column
The below code does just that - however, I am trying to speed up the code execution, and copy and paste actions slow it down. Is there a way to accomplish this without the cut/paste? I'd like to stick with VBA (vice formula) since this is part of a larger procedure.
Thanks!
Sub FindValueAndAboveThenMoveOver ()
Dim sht1 as Worksheet
Set sht1 = Sheets("Convert")
sht1.Columns("A:A").Find("XXXX"), LookIn:=xlValues).Select
Range(ActiveCell.Offset(0, 0), "A1").Select
Selection.Cut
Range("B1").Select
ActiveSheet.Paste
End Sub
Nothing wrong with Cut and Paste, but you can avoid it, and avoiding Select will speed things up. Plus you should check first that you have found something to avoid an error.
Sub FindValueAndAboveThenMoveOver()
Dim sht1 As Worksheet, r As Range
Set sht1 = Sheets("Convert")
Set r = sht1.Columns("A:A").Find("XXXX", LookIn:=xlValues)
If Not r Is Nothing Then
'should add sheet references here too
With Range("A1").Resize(r.Row)
Range("B1").Resize(r.Row).Value = .Value
.ClearContents
End With
End If
End Sub
This might be slightly faster:
Sub FindValueAndAboveThenMoveOver()
Dim sht1 As Worksheet, r As Range
Set sht1 = Sheets("Convert")
With sht1
Set r = Range(.Range("A1"), .Columns("A:A").Find("XXXX", LookIn:=xlValues))
End With
r.Offset(0, 1).Value = r.Value
r.Clear
End Sub
I've been trying to get the code to work for the past week with no luck. I tried various modifications, which ends up giving different error codes.
The first Error I was getting was with Set rng = Intersect(.UsedRange, .Columns(2))
Object doesn’t support this property or method
So then I changed this to just going through the entire column just to see if it would work : Set rng = Range("B:B"), when I do that then it reads through and I get an error for Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value) with the error code:
run time error 1004 Sorry we couldn’t find 24 James.xlsx
Is it possible it was moved, renamed or deleted?
I believe that this line of the code is assuming that the hyperlink should open a different workbook with that name, however this is not the case. The hyperlink on the summary sheet links through to other sheets on the same master workbook, only the templates are on a separate book.
So to overcome this I tried changing this line as well and ended up with the code below, which manages to open the template workbook, and copy just the tab name onto the first sheet and then gives an error for the following line TemplateBook.Sheets("Red").Copy ActiveSheet.Paste, saying
subscript out of range
Sub Summary()
Dim MasterBook As Workbook
Set MasterBook = ActiveWorkbook
With MasterBook
Dim rng As Range
Set rng = Range("B:B")
End With
Dim TemplateBook As Workbook
Set TemplateBook = Workbooks.Open(Filename:=" C:\Users\Desktop\Example template.xlsx")
Dim cell As Range
For Each cell In rng
If cell.Value = "Red" Then
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
TemplateBook.Sheets("Red").Copy ActiveSheet.paste
ElseIf cell.Value = "Blue" Then
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
TemplateBook.Sheets("Blue").Copy ActiveSheet.paste
End If
Next cell
End Sub
I tried several more variations but I just can’t get it to copy the correct template, switch back to the master workbook sheet, follow through the link to correct sheet in the same master workbook, and paste the template.
A few comments about the modifications I made to your code:
Instead of using the entire Column B, try to use only cells in Column B that have values inside them.
Try to avoid using ActiveWorkbook, if the code lies in the same workbook then use ThisWorkbook instead.
When you set a Range, fully qualify it by stating the Workbook and Worksheet, as in : Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row).
I replaced your 2 Ifs with Select Case, as they the result in both is the same, and it will also allow you more flexibility in the future to add more cases.
When you copy an entire sheet with TemplateBook.Sheets("Red") and paste it to another Workbook, the syntax is TemplateBook.Sheets("Red").Copy after:=Sht.
Code
Option Explicit
Sub Summary()
Dim MasterBook As Workbook
Dim Sht As Worksheet
Dim Rng As Range
Set MasterBook = ThisWorkbook '<-- use ThisWorkbook not ActiveWorkbook
Set Sht = MasterBook.Worksheets("Sheet3") '<-- define the sheet you want to loop thorugh (modify to your sheet's name)
Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row) '<-- set range to all cells in column B with values
Dim TemplateBook As Workbook
Set TemplateBook = Workbooks.Open(Filename:="C:\Users\Desktop\Example template.xlsx")
Dim cell As Range
For Each cell In Rng
Select Case cell.Value
Case "Red", "Blue"
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here
TemplateBook.Sheets(cell.Value).Copy after:=Sht '<-- paste after the sheet defined
Case Else
' do something if you have other cases , not sure it's needed
End Select
Next cell
End Sub
Edit 1: to copy>>paste contents of the sheet, use the loop below:
For Each cell In Rng
Select Case cell.Value
Case "Red", "Blue"
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here
Application.CutCopyMode = False
TemplateBook.Sheets(cell.Value).UsedRange.Copy
Sht.Range("A1").PasteSpecial '<-- paste into the sheet at Range("A1")
Case Else
' do something if you have other cases , not sure it's needed
End Select
Next cell
Edit 2: Create a new worksheet, and then rename it with the cell.Offset(0, -1).Value
TemplateBook.Sheets(cell.Value).Copy after:=Sht
Dim CopiedSheet As Worksheet
Set CopiedSheet = ActiveSheet
CopiedSheet.Name = cell.Offset(0, -1)
I am new using macro of Excel, and this is the first time I ask a question here.
I did some research here about this problem, but still can't solve it.
I have several sheets named :page 1, page 2, etc, and I want to copy the data in specific range and paste them to the sheets named "ULD".
When I run the macro in page 1, everything works perfect. But when I run it in page 2 or other sheet, the new data will paste and replace the data pasted from page 1.
The following is my vba code:
Sub test()
Dim ws As Worksheet
Set ws = Sheets("ULD")
'Only Copy Visible Cells'
Range("L3:L100").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("ULD").Activate
For Each cell In ws.Range("I4:I10").Cells
If IsEmpty(cell) = True Then cell.Select.Paste: Exit For
Next cell
End Sub
Besides, I want the data being paste only value, how should I write the code?
There is some confusion, this is how I interpret what you are trying to do.
Sub test2()
Dim ws As Worksheet, LstRw As Long
Set ws = Sheets("ULD")
With ws
LstRw = .Cells(.Rows.Count, "I").End(xlUp).Row
End With
'Only Copy Visible Cells'
Range("L3:L100").SpecialCells(xlCellTypeVisible).Copy
ws.Range("I" & LstRw + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = 0
End Sub
I have an audit that is done daily. I have been asked to save the audit points to a separate sheet for review by the mgmt. team. The code is below but when I run it I get an error: Script out of range.
Sub copy1()
Dim sheet2 As Worksheet
Dim sheet10 As Worksheet
Set sheet2 = Worksheets("sheet2")
Set sheet10 = Worksheets("sheet10")
sheet2.Range("a2:g10").Copy
sheet10.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).pastspecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
It's difficult to say for sure, but it is likely that you are receiving the "Subscript out of range" error because your workbook does not have the worksheets named "Sheet2" and "Sheet10".
The following code copies data from Sheet2 and pastes the values of the data to the next available row on Sheet10.
Sub Copy2()
Dim DestinationStartingCell As Range
Dim SheetRowCount As Long
Worksheets("Sheet2").Range("A2:I29").Copy
SheetRowCount = Worksheets("Sheet10").Rows.Count '1048576 for Excel 2007 and later
Set DestinationStartingCell = Worksheets("Sheet10") _
.Range("A" & SheetRowCount).End(xlUp).Offset(1, 0)
DestinationStartingCell.PasteSpecial xlPasteValues
End Sub
You could use this code
emptyrow=WorksheetFunction.CountA(Workbooks(<workbookname>).Sheets(10).Range("A:A"))+1
Workbooks(<workbookname>).Sheets(10).Cells(emptyrow,1).pastespecial xlPasteValues
to dynamically find the first empty row in Sheet10 to paste to.