Can you explain how I can get away from using select and copy in this code? I want to make it run as efficiently as possible and without screen updating. I know I can set the screenupdating = false, but i prefer to just have the code written better!
Dim i As Integer
For i = 4 To 501
Sheets("Repository").Range("B" & i).Copy
Sheets("Input").Activate
Sheets("Input").Range("M13").Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("M21").Copy
Sheets("Repository").Activate
Sheets("Repository").Range("E" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("U12").Copy
Sheets("Repository").Activate
Sheets("Repository").Range("C" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("V12").Copy
Sheets("Repository").Activate
Sheets("Repository").Range("D" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next i
Thanks so much.
If you're only moving values from one cell to another, there's no need to copy/paste. If you have to copy a lot of formatting over then there may be a need for it. This should accomplish the same thing, in my view it's the simplest way to go about it--
Dim wsRepository as Worksheet
Set wsRepository = ThisWorkbook.Sheets("Repository")
Dim wsInput as Worksheet
Set wsInput = ThisWorkbook.Sheets("Input")
Dim i As Integer
For i = 4 To 501
wsInput.Range("M13") = wsRepository.Range("B" & i)
wsRepository.Range("E" & i) = wsInput.Range("M21")
wsRepository.Range("C" & i) = wsInput.Range("U12")
wsRepository.Range("D" & i) = wsInput.Range("V12")
Next i
You can eliminate a lot of the activating and selecting. Here's how I would write it:
Application.ScreenUpdating = False
For i = 4 To 501
Sheets("Repository").Range("B" & i).Copy
Sheets("Input").Range("M13").PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("M21").Copy
Sheets("Repository").Range("E" & i).PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("U12").Copy
Sheets("Repository").Range("C" & i).PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("V12").Copy
Sheets("Repository").Range("D" & i).PasteSpecial Paste:=xlPasteValues
Next i
Application.ScreenUpdating = True
I would still recommend setting screenupdate to false. It will run a lot faster if it doesn't need to show the user each action it's taking.
First of all you don't need to select/activate/copy... you can simply assign values from one cell to another (with/without using variables). I would do this:
Sub test()
Dim i As Long 'Integer has a strict limit
Dim j As Integer
Dim RepositoryWs As Worksheet
Dim InputWs As Worksheet
Dim destinationCell(1 To 4) As Range
Dim sourceCell(1 To 4) As Range
Set RepositoryWs = Worksheets("Repository")
Set InputWs = Worksheets("Input")
'Static ranges
With InputWs
Set destinationCell(1) = .Range("M13")
Set sourceCell(2) = .Range("M21")
Set sourceCell(3) = .Range("U12")
Set sourceCell(4) = .Range("V12")
End With
For i = 4 To RepositoryWs.Range("B4").End(xlDown).Row 'Not hardcoded -> it works if you'll have more data on Repository sheet
'Dynamic ranges
With RepositoryWs
Set sourceCell(1) = .Range("B" & i)
Set destinationCell(2) = .Range("E" & i)
Set destinationCell(3) = .Range("C" & i)
Set destinationCell(4) = .Range("D" & i)
End With
For j = 1 To 4
destinationCell(j).Value = sourceCell(j).Value
Next j
Next i
End Sub
Related
In below code I need to copy a range from "Output for qualifying" and insert as values in "Output".
It works, but I need the code to stop copy the range when column A start to contain the value zero (0).
Is there a smart way to do that? Hope you guys can help me.
Sub Copy_to_output()
Worksheets("Output for qualifying").Range("A2:A400").Copy
Worksheets("Output").Range("A9").PasteSpecial Paste:=xlPasteValues
Worksheets("Output for qualifying").Range("B2:H400").Copy
Worksheets("Output").Range("E9").PasteSpecial Paste:=xlPasteValues
Worksheets("Output for qualifying").Range("J2:K400").Copy
Worksheets("Output").Range("L9").PasteSpecial Paste:=xlPasteValues
Worksheets("Output for qualifying").Range("Q2:Y400").Copy
Worksheets("Output").Range("N9").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
The only thing I can think of in your situation is to use the Find method.
So, in your code, find the first 0 value, then use that as your row reference for the copy. This is by no means a clean way for the operation, but will do the task.
Sub Copy_to_output()
Dim lZeroRow As Long
lZeroRow = Worksheets("Output for qualifying").Range("A:A").Find(What:="0", LookIn:=xlValues, LookAt:=xlWhole).Row
Worksheets("Output for qualifying").Range("A2:A" & lZeroRow).Copy
Worksheets("Output").Range("A9").PasteSpecial Paste:=xlPasteValues
Worksheets("Output for qualifying").Range("B2:H" & lZeroRow).Copy
Worksheets("Output").Range("E9").PasteSpecial Paste:=xlPasteValues
Worksheets("Output for qualifying").Range("J2:K" & lZeroRow).Copy
Worksheets("Output").Range("L9").PasteSpecial Paste:=xlPasteValues
Worksheets("Output for qualifying").Range("Q2:Y" & lZeroRow).Copy
Worksheets("Output").Range("N9").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Try the next code, please:
Sub Copy_to_output()
Dim shOFQ As Worksheet, shO As Worksheet, lastRow As Long
Set shOFQ = Worksheets("Output for qualifying")
Set shO = Worksheets("Output")
lastRow = shOFQ.Range("A:A").Find(What:="0", LookIn:=xlValues, LookAt:=xlWhole).row
shO.Range("A9").Resize(lastRow, 1).Value = shOFQ.Range("A2:A" & lastRow).Value
shO.Range("E9").Resize(lastRow, shOFQ.Range("B2:H" & lastRow).Columns.Count).Value = shOFQ.Range("B2:H" & lastRow).Value
shO.Range("L9").Resize(lastRow, shOFQ.Range("J2:K" & lastRow).Columns.Count).Value = shOFQ.Range("J2:K" & lastRow).Value
shO.Range("N9").Resize(lastRow, shOFQ.Range("Q2:Y" & lastRow).Columns.Count).Value = shOFQ.Range("Q2:Y" & lastRow).Value
End Sub
No need to use Copy Paste...
Dim lastrow&, lastCol&, myarray As Range
lastrow = Range("A1").End(xlDown).Row
lastCol = Range("XX1").End(xlToLeft).Column
Set myarray = Range("A1").Resize(lastrow, lastCol)
Range("A1", myarray).Select
So i added the above code to recognise the last column and last row and copy the array
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.WindowState = xlNormal
Windows("Ex-Pakistan Calculator Final.xlsm").Activate
Sheets("MRG").Select
'has to find the last row by itself
Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select
ActiveSheet.Paste
Getting an error on the last line "activesheet.paste" saying copy and pasting area isn't the same size, try selecting one cell. enter image description here
Thing is, "Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select" does only select one cell, so I don't see the issue.
Following is an ideal way to copy and paste using range selection. You can change this code as per your requirement.
Sub CopyPaste()
Dim selectRange As range
Dim lastrow As Integer
Application.CutCopyMode = False
Sheets("Sheet1").Activate
lastrow = range("A1").End(xlDown).Row
Set selectRange = range("A1:A" & lastrow)
selectRange.Copy
Sheets("Sheet2").range("B1:B" & lastrow).PasteSpecial xlPasteAll
End Sub
Congrats on starting to use VBA. There's several things in your code that could use improvement. You want to avoid using select (a common beginner task). You also don't even need to move around your sheet, or even use copy/paste.
However, see below where I've broken up your code with some statements to stop and check where you're at. I think this will accomplish what you want, but also help you gain a better grasp of what you're doing (it's always a battle getting started!)
Keep battling.
Sub adfa()
Const turnOnStops As Boolean = True 'change to true or false to review code
Dim WS_Pull As Worksheet:
Set WS_Pull = ActiveSheet 'better to define this with actual sheet name
Dim lastrow As Long:
lastrow = WS_Pull.Cells(Rows.Count, 1).End(xlUp).Row 'this assumes column a has the bottom row and no rows hidden
If turnOnStops Then
Debug.Print "Lastrow is " & lastrow
Stop
End If
Dim lastcol As Long:
lastcol = WS_Pull.Cells(1, Columns.Count).End(xlToLeft).Column 'same assumptions but with columns on row 1 instead of columna a
If turnOnStops Then
Debug.Print "lastcol is " & lastcol
Stop
End If
Dim myarray As Range:
Set myarray = WS_Pull.Range("A1").Resize(lastrow, lastcol) ' I'm not sure what you're trying to do here.
If turnOnStops Then
Dim theAnswer As Long
theAnswer = MsgBox("The address of myArray is " & myarray.Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
Dim WS_paste As Worksheet: Set WS_paste = Sheets("MRG") 'it would be better to use the SHEET (shown in the VBA project)
WS_Pull.Range("A1", myarray).Copy '<--- what are trying to copy.
If turnOnStops Then
theAnswer = MsgBox("The area copied was " & WS_Pull.Range("A1", myarray).Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
If turnOnStops Then
theAnswer = MsgBox("The area you are going to paste to is " & _
WS_paste.Cells(1, Rows.Count).End(xlUp).Offset(2, 0).Address & " stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
End Sub
I need to delete 2 or more (variable depending on work) cells in the same row starting from row 2 if the 2 cells are = ""
I used this code and it's already working fine except 1 problem
Sub Macro3()
Dim s As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
For s = 2 To 22
If ws.Range("G" & (s)) = "" And ws.Range("H" & (s)) = "" Then
Union(ws.Range("G" & s), ws.Range("H" & s)).Select
Selection.Delete Shift:=xlUp
End If
Next s
End Sub
the problem is if I have for example from G2:H4 (2rows or more achieve the if condition) it's only delete half of them,
if 5 rows delete 3 only...etc
so I think the loop doesn't operate on the current cell (just guessing)
Attach screens is before and after running the code for more clarification
before
after
Sub Macro3()
Dim s As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
For s = 22 To 2 Step -1
If ws.Range("G" & s).Value = "" And ws.Range("H" & s).Value = "" Then
ws.Rows(s).Delete Shift:=xlUp
'or:
'ws.Range("G" & s & ":H" & s).Delete Shift:=xlUp
End if
Next s
End Sub
After running the code:
I got one situation and I will try to explain it.
I got excel file with two sheets (Sheet 1-Template, Sheet 2-DB). Template is used by manager who appoints yearly targets on monthly base. After state and approve the targets the data will be copy and pasted into DB. But sometimes manager can change targets after approve step.
In this point I need that if the data stated on Template exist on DB, Update, otherwise insert new lines. Actually I wrote code to insert lines but I couldn't write the proper code for check. Please help me on this issue.
Sub MonthlyTargetDB()
Application.ScreenUpdating = False
Dim Target As Workbook: Set Target = ThisWorkbook
Dim Tmpl As Worksheet: Set Tmpl = Target.Worksheets("Template")
Dim DB As Worksheet: Set DB = Target.Worksheets("DB")
Dim i As Integer: i = DB.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Dim j As Integer: j = DB.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row
Tmpl.Range("A5").Copy
DB.Range(DB.Range("A" & i), DB.Range("A" & i + 11)).PasteSpecial (xlPasteValues)
Tmpl.Range("B5").Copy
DB.Range(DB.Range("B" & j), DB.Range("B" & j + 11)).PasteSpecial (xlPasteValues)
Tmpl.Range(Tmpl.Range("A8"), Tmpl.Range("B8").End(xlDown)).Copy
DB.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValuesAndNumberFormats)
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have the following question.
In the below code i am trying to get my sub to run a loop after the if then statement, and then have the code go back to the first loop and start from the next i. In my below code,everything works fine, but when the condition in the first IF- statement is met, it starts the second loop, but then imidiately exits it again without running it.
So my question is, how do you make a loop after the then statement in a IF- statement?
Sub Sort3()
Dim i As Integer
Dim LastRow As Long
Dim lenght As String
Dim LastRow_2 As String
Dim L_text As Variant
Dim R_text As Variant
Dim M_text As Variant
ThisWorkbook.Sheets("EQ_CLEAN").Select
LastRow = Range("G" & Rows.Count).End(xlUp).Row
LastRow_2 = Range("J" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
lenght = Range("G" & i)
If Len(lenght) = 25 Then
L_text = Left(Range("A" & i), 12)
R_text = Right(Range("A" & i), 12)
For x = 2 To Last_row_2
On Error Resume Next
n = Worksheets("EQ_CLEAN").Range("D1:D6000").Cells.SpecialCells(xlCellTypeConstants).Count
If L_text <> Sheets("EQ_CLEAN").Range("J" & x) Then
Sheets("EQ_CLEAN").Range(Cells(x, 1), Cells(x, 2)).Select
Application.CutCopyMode = False
Selection.Copy
Range("D" & (n + 1)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Next x
End If
Next i
End Sub
Always use Option Explicit at the beginning. That would have flagged up to you that you dim and set LastRow_2, and then try to use Last_row_2...
Code Review
I don't think your question applies to your problem after careful review of your code. You had many errors present which I've corrected for you below:
Option Explicit
Sub Sort3()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("EQ_CLEAN")
Dim LastRow As Long, LastRow_2 As Long
Dim lenght As String
Dim L_text As String, R_text As String, M_text As String
Dim n As Long, x As Long, i As Long
LastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
LastRow_2 = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
For i = 2 To LastRow
lenght = ws.Range("G" & i).Value
If Len(lenght) = 25 Then
L_text = Left(ws.Range("A" & i).Value, 12)
R_text = Right(ws.Range("A" & i).Value, 12)
For x = 2 To LastRow_2
'On Error Resume Next 'You should never use this unless you know exactly which error
'is popping up and why it can't be avoided. Usually this is for 1004 errors that occur
'outside of excel... It's better to use proper error handling instead of skipping all errors.
'You also never tell excel to recognize errors via On Error GoTo 0. I advise you stay away
'from handling errors with these two statements.
'don't make it a habit to assign rogue variables values
n = ws.Range("D1:D6000").Cells.SpecialCells(xlCellTypeConstants).Count
If L_text <> ws.Range("J" & x).Value Then
ws.Range(ws.Cells(x, 1), ws.Cells(x, 2)).Copy
ws.Range("D" & (n + 1)).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = xlCopy 'this is the proper format to remove the marching ants
End If
Next x
End If
Next i
End Sub
I tried to put comments where changes were made.
I ran your code on a blank sheet and it doesn't throw any errors. See if it achieves what you're looking for.
Literature To Reference
Error Handling
Avoiding Use of .Select
What Microsoft says about Option Explicit
Why I changed your Row based variables to Long