I'm looking for a formula that will copy rows from one sheet to another sheet based on certain criteria (specifically, whether or not the row is highlighted). How would one go about doing this?
I ended up just using VBA. I had to use a yes/no cell at the beginning to specify whether or not to highlight a row, so that it would auto-update whenever anyone changed a value.
Sub Autosort()
Application.ScreenUpdating = False
Sheets(2).Select
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Clear
Sheets(3).Select
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Clear
Sheets(1).Select
FinalColumn = Cells(1, 1).End(xlToRight).Column
FinalRow = 1
For x = 1 To FinalColumn
thisRow = Cells(Rows.Count, x).End(xlUp).Row
If thisRow > FinalRow Then
FinalRow = thisRow
End If
Next x
For x = 2 To FinalRow
IsCompleted = Cells(x, 1).ValueThen
If IsCompleted = "Yes" Then
Cells(x, 1).Resize(1, FinalColumn).Interior.ColorIndex = xlColorIndexNone
Cells(x, 1).Resize(1, FinalColumn).Copy
Sheets(2).Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets(1).Select
ElseIf IsCompleted = "No" Then
Cells(x, 1).Resize(1, FinalColumn).Interior.ColorIndex = 6
Cells(x, 1).Resize(1, FinalColumn).Copy
Sheets(3).Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets(1).Select
Else
Cells(x, 1).Value = "No"
Cells(x, 1).Resize(1, FinalColumn).Interior.ColorIndex = 6
Cells(x, 1).Resize(1, FinalColumn).Copy
Sheets(3).Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets(1).Select
End If
Next x
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Related
I wrote a script to find duplicate values in Colomn B. They can be alot of duplicates :
Value1
Value2
Value3
Value1
Value2
But never more than twice. I need to get the values from C column to M column from the second duplicate of B column and paste it on the first duplicate C to M column. After, i need to delete the second duplicate row.
The script work only for one instance of duplicate..
Sub hi()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("B100").End(xlUp).Row
For iCntr = 6 To lastRow
If Cells(iCntr, 2) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 2), Range("B1:B" & lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 3).Copy
Cells(matchFoundIndex, 3).Select
ActiveSheet.Paste
Cells(iCntr, 4).Copy
Cells(matchFoundIndex, 4).Select
ActiveSheet.Paste
Cells(iCntr, 5).Copy
Cells(matchFoundIndex, 5).Select
ActiveSheet.Paste
Cells(iCntr, 6).Copy
Cells(matchFoundIndex, 6).Select
ActiveSheet.Paste
Cells(iCntr, 7).Copy
Cells(matchFoundIndex, 7).Select
ActiveSheet.Paste
Cells(iCntr, 8).Copy
Cells(matchFoundIndex, 8).Select
ActiveSheet.Paste
Cells(iCntr, 9).Copy
Cells(matchFoundIndex, 9).Select
ActiveSheet.Paste
Cells(iCntr, 10).Copy
Cells(matchFoundIndex, 10).Select
ActiveSheet.Paste
Cells(iCntr, 11).Copy
Cells(matchFoundIndex, 11).Select
ActiveSheet.Paste
Cells(iCntr, 12).Copy
Cells(matchFoundIndex, 12).Select
ActiveSheet.Paste
Cells(iCntr, 13).Copy
Cells(matchFoundIndex, 13).Select
ActiveSheet.Paste
Rows(iCntr).EntireRow.Delete
End If
End If
Next
End Sub
Can you please help me clean this script ! Thank you !
Please, try using the next code. It uses a dictionary to keep the row of the first occurrence and copy the range C:M of the second occurrence to the first one. It does it without selecting, without using clipboard, in a fast way. All second occurrence cells are placed in a union range and deleted at the end, at once. In fact, the actual code only selects the rows containing the second occurrence. If it returns as you need, you only have to replace Select with Delete in the last code line:
Sub hi()
Dim lastRow As Long, iCntr As Long, rngDel As Range, dict As Object
lastRow = Range("B" & rows.count).End(xlUp).row
Set dict = CreateObject("Scripting.Dictionary")
For iCntr = 6 To lastRow
If cells(iCntr, 2) <> "" Then
If Not dict.Exists(cells(iCntr, 2).value) Then
dict.Add cells(iCntr, 2).value, iCntr 'the first occurrence row as item
Else
'copy the C:M range to the row of the first occurrence
Range("C" & dict(cells(iCntr, 2).value) & ":M" & dict(cells(iCntr, 2).value)).value = _
Range("C" & iCntr & ":M" & iCntr).value
If rngDel Is Nothing Then
Set rngDel = cells(iCntr, 2)
Else
Set rngDel = Union(rngDel, cells(iCntr, 2))
End If
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if selected what you need, replace Select with Delete
End Sub
The above code copies the rows of the second occurrence (C:M) to the row of the first one. Otherwise, it will not make any sense to copy anything on rows to be deleted...
Private Sub CommandButton21_Click()
a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 3).Value = "shipment oi" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
b = Worksheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Code manages to reflect from A2 onwards
How do I make it reflect in D2 instead?
Struggle with this code below.
What I am trying to achieve is I have a purchase order form which when one is generated I would like to be able to copy certain cells to a purchase order log on a different sheet.
Currently I have this code
Sub Range_PasteSpecial_Values1()
Worksheets("Sheet1").Range("A1").Copy
Worksheets("Sheet2").Range("A10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("B1").Copy
Worksheets("Sheet2").Range("B10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("C1").Copy
Worksheets("Sheet2").Range("C10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("D1").Copy
Worksheets("Sheet2").Range("D10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("E1").Copy
Worksheets("Sheet2").Range("E10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("F1").Copy
Worksheets("Sheet2").Range("F10").PasteSpecial Paste:=xlPasteValues
End Sub
Which works but it does copy these cells into the row below in my purchase orders log.
Hope this is clear and thanks for your help
Public Sub CopyRows()
Sheets("Sheet1").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 4).Value
If ThisValue = "A" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("SheetA").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ElseIf ThisValue = "B" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("SheetB").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next x
End Sub
why twb cells(i,7) value don't show up in the extwb(pasterowIndex, 1)?
can you make this
twb.Sheets(1).Activate
Cells(i, 7).Select
Selection.Copy
extwb.Sheets(8).Activate
Cells(pasterowIndex, 1).Select
ActiveSheet.Paste
code little simple, because I have many value to copy?
Sub historical()
Dim twb As Workbook
Dim extwb As Workbook
Dim extwb3 As Worksheet
Dim i As Long
Dim pasterowIndex As Long
pasterowIndex = 2
Set twb = Workbooks.Open("C:\Users\faisal.abraham\Documents\Travel\PUPD.xlsx")
Set extwb = Workbooks.Open("C:\Users\faisal.abraham\Documents\Travel\PIRD.xlsx")
With twb.Sheets("Actuary_Travel_Voucher_Engineer")
For i = 8 To Cells(Rows.Count, 1).End(xlUp).Row
If twb.Cells(i, 23).Value = "PERMATA HIJAU " And Cells(i, 28).Value = "PAID" Then
twb.Sheets(1).Activate
Cells(i, 7).Select
Selection.Copy
extwb.Sheets(8).Activate
Cells(pasterowIndex, 1).Select
ActiveSheet.Paste
pasterowIndex = pasterowIndex + 1
End If
Next i
pasterowIndex = 2
End With
End Sub
This code
twb.Sheets(1).Activate
Cells(i, 7).Select
Selection.Copy
extwb.Sheets(8).Activate
Cells(pasterowIndex, 1).Select
ActiveSheet.Paste
can be replaced with
twb.Sheets(1).cells(i,7).copy extwb.sheets(8).cells(pasteindex,1)
Which doesn't fix the other issues but at least makes the code less painful
With Excel VBA, I would like to have a button which adds a new 'Feature #' column before the 'Total' column, every time the button is pressed.
Basically, a button that does the following, from image 1 -> 2 -> 3.
1.
2.
3.
Update:
Assuming your Table is from Cell A2 try the following:
Sub InsertColumn()
Dim lastColumn As Long, lastRow As Long
lastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Columns(lastColumn - 1).Select
Range(Selection, Selection).Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Application.CutCopyMode = False
Cells(2, lastColumn).Value = "Feature" & " " & lastColumn - 1
Range(Cells(3, lastColumn), Cells(lastRow, lastColumn)).ClearContents
Cells(1, 1).Select
End Sub
EDIT:
_________________________________________________________________________________
This code should work for updated question or the image added.
Sub InsertColumn111()
Dim lastColumn As Long, lastRow As Long
Dim rConstants As Range
lastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
lastRow = Range("A1").End(xlDown).Row
Columns(lastColumn - 1).Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Application.CutCopyMode = False
Cells(2, lastColumn).Value = "Feature" & " " & lastColumn - 1
Range(Cells(3, lastColumn), Cells(lastRow, lastColumn)).ClearContents
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows(lastRow - 1).Select
Selection.Copy
Selection.Insert Shift:=xlToBottom
Application.CutCopyMode = False
Cells(lastRow, 1).Value = "Feature" & " " & lastRow - 7
Set rConstants = Range(Cells(lastRow, 2), Cells(lastRow, lastColumn)).SpecialCells(xlCellTypeConstants)
rConstants.ClearContents
Cells(1, 1).Select
End Sub
Assuming data starting with A1 (Pls. refer the image below)
Sub Button1_Click()
columntoinsert = Cells(1, 1).End(xlToRight).Column
Columns(columntoinsert).Insert
Cells(1, columntoinsert) = "Feature" & columntoinsert - 1
End Sub
After the button click: