I have the following macro running on a workbook to copy data with a specific criteria from "Master" sheet to "Quarantined" sheet;
Dim LR As Long, LR2 As Long
Application.ScreenUpdating = False
With Sheets("Quarantined")
LR2 = .Range("L" & Rows.Count).End(xlUp).Row
If LR2 > 2 Then
.Range("A3:I" & LR2).ClearContents
End If
End With
With Sheets("Master")
LR = .Cells(Rows.Count, 8).End(xlUp).Row
LR2 = Sheets("Quarantined").Range("L" & Rows.Count).End(xlUp).Row
With .Range("L2:L" & LR)
.AutoFilter Field:=1, Criteria1:="QUARANTINED"
.Offset(1).Resize(LR).EntireRow.Copy Sheets("Quarantined").Range("A" & LR2 + 1)
.AutoFilter
End With
End With
Application.ScreenUpdating = True
It works perfectly but if I update the master and run the macro again it pastes it under the original information on the quarantined sheet. How do I get it to overwrite the information that was already there instead of pasting underneath?
Here's hoping
It is pasting under the original info because you are telling it to.
You are clearing your range from .Range("A3:I" & LR2).ClearContents but you are taking the next available row from Col L LR2 = Sheets("Quarantined").Range("L" & Rows.Count).End(xlUp).Row
Either Change your code to this
.Range("A3:L" & LR2).ClearContents
or take the last row based on Col A instead of Col L
Related
I am trying to copy data from multiple tabs to one single tab. The data need to be filtered first then copied from different tabs to a new tab. Data from different tabs (has random number of lines)should be continuous within the new tab. Due to the size of the data, it is divided into multiple tabs. So merging tabs into one tab first is not an option.
I have below difficulties that need help:
From second tab, I don’t need to copy the header of data. Any command can be added to the code?
Current codes not copying all four tabs, I am not too sure what is the issue
Can my active sheet be a general command instead of specific like ActiveSheet.Range("$A$1:$U$493692")?
See below code
Sub Filter_FSI()
'
' Filter_FSI Macro
'
'
Dim lastRow As String
lastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Train 3-8").Select
ActiveSheet.Range("$A$1:$U$493692").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A1").Select
Sheets("Sheet1").Paste
Sheets("Train 9-14").Select
ActiveSheet.Range("$A$1:$U$539243").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Train 15-25").Select
ActiveSheet.Range("$A$1:$U$528028").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Train 27-41").Select
ActiveSheet.Range("$A$1:$U$298055").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Copy
Windows("Train Data JULY_Sam Edit.xlsb").Activate
End Sub
So a couple things I noticed with your code - you're declaring lastrow as a string, but that should really be a long since it's representing a number.
Personally, I'm not a fan of autofiltering - and like Peh said above, you want to avoid using Select and Copy/Paste when you can. Try this solution below - it's my personal preference of doing things. We loop through all your worksheets, then loop through every cell in Column D - if it is equal to "FSI", we bring it to Sheet1:
Option Explicit
Sub Filter_FSI()
Dim sht As Worksheet, sht2 As Worksheet
Dim lastrow As Long, i As Long, j As Long, k As Long
Dim myworksheets As Variant
Set sht = ThisWorkbook.Worksheets("Sheet1")
myworksheets = Array("Train 3-8", "Train 9-14", "Train 15-25", "Train 27-41")
'Bring in headers
sht.Range("A1:U1").Value = Worksheets("Train 3-8").Range("A1:U1").Value
k = 2
For i = 0 To UBound(myworksheets)
Set sht2 = Worksheets(myworksheets(i))
lastrow = sht2.Cells(sht2.Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If sht2.Cells(j, 4).Value = "FSI" Then
sht.Range("A" & k & ":U" & k).Value = sht2.Range("A" & j & ":U" & j).Value
k = k + 1
End If
Next j
Next i
End Sub
I am new to this but I am trying to copy multiple cells in an excel workbook and paste them into a separate tab of the same workbook.
Above is a sample of what my spreadsheet looks like, but my spreadsheet has over 800 lines of data.
I need the names to be copied and put into column A of Sheet2 and then the account numbers into column D of Sheet2.
I have tried this 2 different ways.
Using below code:
Sheets("Sheet1").Select
Range("A1,A3,A5,A7,A9").Select
Range("A10").Activate
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2,A4,A6,A8,A10").Select
Range("A10").Activate
Selection.Copy
Sheets("Sheet2").Select
Range("D1").Select
ActiveSheet.Paste
This gives me a Compile Error Syntax Error.
Code #2
Range("A2").Select
Selection.Cut
Range("D1").Select
ActiveSheet.Paste
Range("A4").Select
Selection.Cut
Range("D3").Select
ActiveSheet.Paste
...
This is keeping them in the same tab, instead of pasting them into a separate tab (I would just copy them over later). I repeat this for each customer. This one gives me a range error that basically says it's too large. Unfortunately, I can't recreate it because I deleted it.
Does anyone have a simpler way of doing this that won't cause an error?
Try this is assuming your data is consistently alternating (Name,acount).
Sub marine()
Dim lr As Long, i As Long
Dim sh1 As Worksheet, sh2 As Worksheet
'/* declare the worksheets and use variables in the rest of the code */
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
lr = .Range("A" & .Rows.Count).End(xlUp).Row '/* get the last row in Sheet1 */
For i = 1 To lr '/* loop to all rows identified */
If i Mod 2 = 1 Then '/* check if odd or even, copy in A if odd */
.Range("A" & i).Copy _
sh2.Range("A" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
Else '/* copy in D otherwise */
.Range("A" & i).Copy _
sh2.Range("D" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
End With
End Sub
Above copies data from Sheet1 to Sheet2 but leaves the 1st row blank.
Also, it always copy data on the last row of each column in Sheet2 (A and D). So another approach would be:
Sub ject()
Dim lr As Long, i As Long, lr2 As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rNames As Range, rAcct As Range
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lr
If i Mod 2 = 1 Then
If rNames Is Nothing Then '/* get all the cells with names */
Set rNames = .Range("A" & i)
Else
Set rNames = Union(rNames, .Range("A" & i))
End If
Else
If rAcct Is Nothing Then '/* get all the cells with accounts */
Set rAcct = .Range("A" & i)
Else
Set rAcct = Union(rAcct, .Range("A" & i))
End If
End If
Next
End With
With sh2
'/* get the last filled Names column in Sheet2 */
lr2 = .Range("A" & .Rows.Count).End(xlUp).Row
rNames.Copy .Range("A" & lr2) '/* execute 1 time copy */
rAcct.Copy .Range("D" & lr2) '/* execute 1 time copy */
End With
End Sub
Above code ensures that the correct account is adjacent to the correct name.
And you might gain execution performance too since one(1) time copy is executed. HTH.
P.S. As much as possible, avoid using Select.
Logic I implemented is to loop until last row in Sheet1 in step of 2. Loop variable indicates always row with name, the following row is account number, so it's easy in a loop to assign these values to particular columns on the other sheet. Also, I used another variable j, which indicates consecutive rows in Sheet2.
Solution:
Sub CopyData()
Dim sourceWs As Worksheet, targetWs As Worksheet, i As Long, lastRow As Long, j As Long
j = 1
Set sourceWs = Worksheets("Sheet1")
Set targetWs = Worksheets("Sheet2")
lastRow = sourceWs.Cells(sourceWs.Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow Step 2
targetWs.Cells(j, 1) = sourceWs.Cells(i, 1)
targetWs.Cells(j, 4) = sourceWs.Cells(i + 1, 1)
j = j + 1
Next
End Sub
I want to copy all the rows from the Pipeline Report sheet that contain the text "AllScripts" in column T.
Then, I want to paste them onto another sheet starting from "A14" and go down.
Right now this code pastes them from "A2" but I need it to start from A14 and go down from there.
Sub extractAllscripts()
Dim myrange As Range
Dim lr as Long
Sheets("Pipeline Report").Select
Set myrange = Sheets("Pipeline Report").Range("T1", Range("T" & Rows.Count).End(xlUp))
For Each cell In myrange
If cell.Value = "Allscripts" Then
lr = Sheets("Macro Test Page").Range("T" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy Destination:=Sheets("Macro Test Page").Range("A" & lr + 1)
End If
Next cell
End Sub
This is a bad practice but as we don't know how your sheet is set up, then I would suggest this:
Sub extractAllscripts()
Dim myrange As Range
Dim lr as Long
Dim myoffset As Integer
Sheets("Pipeline Report").Select
Set myrange = Sheets("Pipeline Report").Range("T1", Range("T" & Rows.Count).End(xlUp))
myoffset = 13
For Each cell In myrange
If cell.Value = "Allscripts" Then
lr = Sheets("Macro Test Page").Range("T" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy Destination:=Sheets("Macro Test Page").Range("A" & lr + myoffset)
End If
myoffset = 1
Next cell
End Sub
Or another bad solution:
In your code substitute lr = Sheets("Macro Test Page").Range("T" & Rows.Count).End(xlUp).Row with lr = lr + 1 and define lr to be 13 outside of the loop and in the Range("A" & lr + 1) use lr instead of lr + 1.
This is the code that I have written, but basically I want to copy data from one worksheet to another with a condition e.g :"closed", and by doing that the row in the old worksheet must be deleted. I was able to copy a row to another sheet but it was copying the row 4 times, I can't figure out why. Can you please look at this code? I'm not so advanced with VBA.
Sub macro_1()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
Last = Cells(Rows.Count, "G").End(xlUp).Row
For i = Last To 2 Step 1
If Range("G" & r).Value = "closed" Then
Rows(r).Copy Destination:=Sheets("Sheet2").Range("A" & lr2 + 1)
lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
End If
If (Cells(i, "G").Value) = "closed" Then 'Cells (i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
Cells(i, "A").EntireRow.Delete
End If
Next i
Next r
End Sub
You don't need the second loop, that is what is causing your problems.
Also it is good practice to always declare the parents of your objects. The code below declares the two sheets, then every range is qualified to the proper sheet. This way if for some reason the focus is lost to the active sheet, errors are not encountered.
It also makes it easier to rename the sheets. The name only needs to be fixed in one place not many.
Sub macro_1()
Dim lr As Long, lr2 As Long, r As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
lr = ws1.Cells(Rows.count, "A").End(xlUp).Row
For r = lr To 2 Step -1
lr2 = ws2.Cells(Rows.count, "A").End(xlUp).Row + 1
If ws1.Range("G" & r).value = "closed" Then
ws1.Rows(r).copy Destination:=ws2.Range("A" & lr2)
ws1.Cells(r, "A").EntireRow.Delete
End If
Next r
End Sub
I am Trying to build a vba script for excel with to check if value (ex: First and Last Name) in sheet1 exist in sheet2 then if exist copy the entire row from sheet1 and past it in sheet2 in the same position where it find it
i succeeded to check if the Name exist and past it but in the end table not where it find it
Sub test()
Dim LR As Long, i As Long
LR = Range("C" & Rows.Count).End(xlUp).Row
LR2 = ThisWorkbook.Sheets("Feuil2").Range("C" & Rows.Count).End(xlUp).Row
For i = 14 To LR
For j = 14 To LR2
If Range("C" & i).Value = ThisWorkbook.Sheets("Feuil2").Range("C" & j).Value Then Rows(i).Copy Destination:=Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next j
Next i
End Sub
any ideas ?? Thank you !
You can also use find to find the value and get the row number.
Sub test2()
Dim Rws As Long, rng As Range, c As Range, sh As Worksheet, Fx As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range(Cells(14, "C"), Cells(Rws, "C"))
Set sh = Sheets("Feuil2")
For Each c In rng.Cells
With sh
Set Fx = .Columns(3).Find(what:=c, lookat:=xlWhole)
If Not Fx Is Nothing Then
c.Offset(0, -2).Range("A1:B1").Copy sh.Range("A" & Fx.Row)
End If
End With
Next c
End Sub