Excel VBA, Copying Colored Rows - vba

I have a list in "Sheet1" with three Columns, A (Account Number), B (Description) & C (Amount). Based on 1st two columns (A & B) color, I want to copy the specific row to "Sheet2" and Paste it under one specific header (I have three headers).
Example
Sheet1 - Cell A2 is "Red" & B2 is "Yellow", Copy/Paste Under Header "Inefficiencies" in Sheet2
Sheet1 - Cell A3 is "Blue" & B3 is "No Color" Copy/Paste Under Header "Effective" in Sheet2
Account Number Description Amount
LP001022 Graduate 3,076.00
LP001031 Graduate 5,000.00
LP001035 Graduate 2,340.00
I have taken a code from this site already, but I could not completely configure it to my needs. Thank you for the help in advance.
Sub lastrow()
Dim lastrow As Long
Dim i As Long, j As Long
Dim acell As Range
With Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (lastrow)
With Worksheets("Sheet3")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To lastrow
With Worksheets("Sheet1")
If .Cells(i, 1).Interior.Color = RGB(255, 255, 0) And _
.Cells(i, 1).Interior.ColorIndex = xlNone Then
.Rows(i).Copy 'I have to give destination
j = j + 1
End If
End With
Next i
End Sub

Here are the key instructions to copy a row from sheet1 to INSERT into a row in sheet2. This assumes you have all the row numbers.
' -- to copy a row in sh1 to INSERT into sh2:
sh2.Rows(irowInefficiency + 1).Insert
sh1.Rows(irowFrom).Copy sh2.Rows(irowInefficiency + 1)
' -- you have to increment all header rows after this one
irowEffective = irowEffective + 1
The following puts these in context:
Sub sub1() ' copy/insert a row
Dim irowFrom&, irowInefficiency&, irowEffective&
Dim sh1, sh2 As Worksheet
Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")
irowInefficiency = 3 ' where that header is
irowEffective = 6 ' where that header is
irowFrom = 5 ' the row to copy
' -- to copy a row in sh1 to INSERT into sh2:
sh2.Rows(irowInefficiency + 1).Insert ' a blank row
sh1.Rows(irowFrom).Copy sh2.Rows(irowInefficiency + 1) ' then copy
' -- you have to increment all header rows after this one
irowEffective = irowEffective + 1 ' because it increases
End Sub

Related

VBA. Replace a table cell content based on match from another table or delete entire row if match is not found

I am trying to make the following to work:
There are two tables in a separate worksheets. I want it to check each cell in worksheet2 column B and find a match from worksheet1 column A. If a match is found then replace the data in worksheet2 column B with a data from a matching row of worksheet1 column B.
If a match is not found from a worksheet1 column A then delete entire row in a worksheet2 column B.
Sub match_repl_del()
Dim r1 As Long, rfound, vfound
Dim w1, w2, v As Long
Set w1 = Sheets(3) ' data sheet
Set w2 = Sheets(2) ' target sheet
r1 = 2 'data starting from row 2
Do While Not IsEmpty(w1.Cells(r1, 1))
v = w1.Cells(r1, 1)
rfound = Application.Match(v, w2.Columns(2), 0) ' look for value
If Not IsError(rfound) Then ' found it?
vfound = w2.Cells(rfound, 2)
If w1.Cells(r1, 2) <> vfound Then ' if value does not match sheet1 column b
w2.Cells(rfound, 2) = w1.Cells(r1, 2) ' update based on origin sheet
lastC = w2.Cells(rfound, 1).End(xlToRight).Column
w2.Range(w2.Cells(rfound, 1), w2.Cells(rfound, lastC)).Interior.ColorIndex = 5
Else ' delete entire row on sheet2 if match is not found
w2.Rows(r1).EntireRow.Delete
End If
End If
r1 = r1 + 1
Loop
End Sub
Try this wat, it's work for me :
Option Explicit
Sub test()
' Active workbook
Dim wb As Workbook
Set wb = ThisWorkbook
Dim i As Long
Dim j As Long
'*******************************************
'Adapt this vars
'define your sheets
Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Set ws_1 = wb.Sheets("Sheet1") 'find a match in worksheet1 column A
Set ws_2 = wb.Sheets("sheet2") 'cell in worksheet2 column B
'definie the last Rows
Dim lastRow_ws1 As Long
Dim lastRow_ws2 As Long
lastRow_ws1 = ws_1.Range("A" & Rows.Count).End(xlUp).Row 'if you need, adjust column to find last row
lastRow_ws2 = ws_2.Range("B" & Rows.Count).End(xlUp).Row 'if you need, adjust column to find last row
'*******************************************
For i = lastRow_ws2 To 2 Step -1
For j = 1 To lastRow_ws1
Dim keySearch As String
Dim keyFind As String
keySearch = ws_2.Cells(i, 2).Value
keyFind = ws_1.Cells(j, 1).Value
If keySearch = keyFind Then
'MsgBox keySearch & " " & keyFind & " yes"
ws_2.Cells(i, 2).Value = ws_1.Cells(j, 2).Value
GoTo next_i
End If
Next j
ws_2.Rows(i).EntireRow.Delete
next_i:
Next i
End Sub

Compare 2 Sheets, Export Unique Rows to Another Sheet

I am being providing two contact lists as CSVs. List 2 is a new export. List 1 is from a week prior. However, List 2 includes the contacts from List 1.
This is not a matter of "Remove Duplicates" because I want to extract only the unique rows.
I have List 1 in Sheet1. I have List 2 in Sheet2. Sheet3 is empty. I need to compare Column 3 (email address) in List 1 to Column 3 (email address) in List 2 and EntireRow.Copy where Column 3 is unique, i.e. it appears ONLY in List 2, NOT in List 1.
I am no stranger to conditional logic, but I've never used Excel Macros / VBA like this. I was able to find a solution (see "2nd code") to export duplicates to a new sheet, and tried to modify it to export uniques, but I wasn't able to make it work.
EDIT 1
This is the code I modified from the aforementioned answer.
Option Explicit
Sub FilterAndCopy2()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range, _
unionRng As Range
Dim i As Long, iOld As Long
Set wstSource = Worksheets("DUPLICATE LIST FILTER")
Set wstOutput = Worksheets("UNIQUE LIST RESULTS")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wstSource
Set rngMyData = .Range("A1:K" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
With rngMyData
Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
Set unionRng = .Cells(1000, 1000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
End With
With helperRng
.FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
.Value = .Value
End With
With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
.Sort key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data to have all same columnA values grouped one after another
i = .Rows(1).Row 'start loop from data first row
Do While i < .Rows(.Rows.Count).Row
iOld = i 'set current row as starting row
Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
iOld = iOld + 1
Loop
If iOld - i = 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
i = iOld + 1
Loop
Intersect(unionRng, rngMyData).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
.Sort key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data in wstSource back
End With
helperRng.Clear 'delete "helper" column, not needed anymore
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The result is not comparing the Email column. I found a known duplicate in my data, and modified the email address. The row was not exported to the target Sheet.
NOTE: This in-progress solution does not use 3 separate sheets as I described above, only two.
Code below is assuming you don't need to actually copy/paste the row but rather transfer the value in the result sheet.
Sub find_unique()
Application.ScreenUpdating = False
Dim Wb As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim P1 As Range, P2 As Range, a As Integer
Set Wb = Workbooks("unique.xlsm")
Set Sh1 = Wb.Sheets(1) ' Adapt to original list
Set Sh2 = Wb.Sheets(2) ' Adapt to updated list
Set Sh3 = Wb.Sheets(3) ' Adapt to destination sheet
Set P1 = Sh1.UsedRange
Set P2 = Sh2.UsedRange
Set D1 = CreateObject("scripting.dictionary")
T1 = P1
For i = 2 To UBound(T1)
D1(UCase(T1(i, 1))) = UCase(T1(i, 1)) 'Change 1 for the column number of your unique identifier
Next i
T2 = P2
a = 1
Dim T3()
For i = 1 To UBound(T2)
If i = 1 Then 'Considering you have headers
ReDim Preserve T3(1 To UBound(T2, 2), 1 To a)
For j = 1 To UBound(T2, 2)
T3(j, a) = T2(i, j)
Next j
a = a + 1
Else
If Not D1.exists(UCase(T2(i, 1))) Then 'Change 1 for the column number of you unique identifier
ReDim Preserve T3(1 To UBound(T2, 2), 1 To a)
For j = 1 To UBound(T2, 2)
T3(j, a) = T2(i, j)
Next j
a = a + 1
End If
End If
Next i
Sh3.Cells.Clear 'Assuming you want to replace the result in sheet(3) each time
Sh3.Range("A1").Resize(UBound(T3, 2), UBound(T3, 1)) = Application.Transpose(T3)
Application.ScreenUpdating = True
End Sub
Other option if you really want to copy/paste the unique row :
Sub find_unique2()
Application.ScreenUpdating = False
Dim Wb As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim P1 As Range, P2 As Range, a As Integer
Set Wb = Workbooks("unique.xlsm")
Set Sh1 = Wb.Sheets(1) ' Adapt to original list
Set Sh2 = Wb.Sheets(2) ' Adapt to updated list
Set Sh3 = Wb.Sheets(3) ' Adapt to destination sheet
Set P1 = Sh1.UsedRange
Set P2 = Sh2.UsedRange
Set D1 = CreateObject("scripting.dictionary")
T1 = P1
For i = 2 To UBound(T1)
D1(UCase(T1(i, 1))) = UCase(T1(i, 1)) 'Change 1 for the column number of your unique identifier
Next i
T2 = P2
a = 2
Sh3.Cells.Clear
For i = 1 To UBound(T2)
If i = 1 Then 'Considering you have headers
Sh2.Rows(1).Copy Sh3.Rows(1)
Else
If Not D1.exists(UCase(T2(i, 1))) Then 'Change 1 for the column number of you unique identifier
Sh2.Rows(i).Copy Sh3.Rows(a)
a = a + 1
End If
End If
Next i
Application.ScreenUpdating = True
End Sub

Match, Copy, and Add Values between Sheets

Looking to match values of column 1&2 of the same row on sheet2 to values of column 1&2 of the same row on sheet1. Then, copy entire row of sheet1 match onto next blank row of sheet3 + copy value of column 3+4 of same row sheet2 onto end of pasted row on sheet3.
IF Sheet2 Row First&Last (column1&2) Name match Sheet1 Row First&Last (column1&2)
THEN
Copy Sheet1 Row, paste to Sheet3 # next blank Row. Copy Sheet2 Row column 3+4 # end of previously pasted Row on Sheet3
Here is what I have so far, this doesn’t do anything right now but I have pieced it together from a few working macros to try and accomplish what I’m after. I haven’t been able to find examples of “Copy Sheet2 Row column 3+4 # end of previously pasted Row on Sheet3” so I just have a description on the line where I think the code should go.
Sub Match_Copy_AddValues()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Set s1 = ActiveSheet 'List with dump data'
Set s2 = Sheets("Sheet 2") 'List of names to match, and additional information to be added'
Set s3 = Sheets("Sheet 3") 'Worksheet to copy rows of matched names'
Dim r As Long 'Current Row being matched?'
On Error GoTo fìn
Set ws2 = Sheets("Sheet 2")
With Sheets("Sheet 1")
r = Application.Max(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(Rows.Count, 2).End(xlUp).Row) 'Defines # of rows to apply If/Then to?'
For r = Application.Sum(v) To 2 Step -1 'Each time If/Then is ran, reduce # of rows to apply If/Then to?'
If CBool(Application.CountIfs(ws2.Columns(1), .Cells(r, 1).Value, ws2.Columns(2), .Cells(r, 2).Value)) Then _
.Rows(r).EntireRow.Copy s3.Cells(K, 1) 'Compares value in (r)row column 1 and 2, sheet2, to sheet1(activesheet), if equal THEN copies entire (r)row onto sheet3 # next empty row'
'take (r)row of match and copy value of column 3 and 4 sheet2 onto the end of previously pasted row on sheet3'
Next r
End With
fìn:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The code below doesn't do everything just the way your attempt suggests but I wrote it in very plain language so that you will surely be able to teak it back into your track where it has transgressed to where it shouldn't go.
Sub MatchNameAndInfo()
' 02 Aug 2017
Dim WsInput As Worksheet
Dim WsInfo As Worksheet
Dim WsOutput As Worksheet
Dim Rl As Long ' Last row of WsInput
Dim R As Long ' WsInput/WsInfo row counter
Dim Tmp1 As String, Tmp2 As String ' Clm 1 and Clm2 Input values
Dim Cmp1 As String, Cmp2 As String ' Clm 1 and Clm2 Info values
Set WsInput = Worksheets("Krang (Input)")
Set WsInfo = Worksheets("Krang (Info)")
Set WsOutput = Worksheets("Krang (Output)")
Application.ScreenUpdating = False
With WsInput
Rl = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(.Rows.Count, 2).End(xlUp).Row)
If Rl < 2 Then Exit Sub
For R = 2 To Rl ' define each input row in turn
Tmp1 = Trim(.Cells(R, 1).Value)
Tmp2 = Trim(.Cells(R, 2).Value)
Cmp1 = Trim(WsInfo.Cells(R, 1).Value)
Cmp2 = Trim(WsInfo.Cells(R, 2).Value)
If StrComp(Tmp1 & Tmp2, Cmp1 & Cmp2, vbTextCompare) = 0 Then
TransferData R, WsInfo, WsOutput
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Function TransferData(R As Long, _
WsInfo As Worksheet, _
WsOut As Worksheet)
' 02 Aug 2017
Dim Rng As Range
Dim Rt As Long ' target row
With WsInfo
Set Rng = .Range(.Cells(R, 1), .Cells(R, 4))
End With
With WsOut
Rt = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 2)
Rng.Copy Destination:=.Cells(Rt, 1)
End With
End Function

Copy data from one worksheet to other based on condition

I am trying to copy data from one worksheet to another blank worksheet in a workbook. It has three columns where in I want to search a specific 'Unit' value and just copy all of the records with similar 'Unit' values into second worksheet with similar column structure.
**Doc_number** **Doc_version** **Unit**
43449 01 D013-LAG R
43450 02 D013-LAG R
43451 01 D013-DAMP
43452 02 D013-DAMP
Output should be like this if I provide D013-LAG R as input value ;
**Doc_number** **Doc_version** **Unit**
43449 01 D013-LAG R
43450 02 D013-LAG R
I want to paste the selected column to the DELIVERY sheet like if I pass 'Unit' value as 'D03-LAG R' then the output in the DELIVERY file should be just like as follows;
Doc_version Unit
01 D013-LAG R
02 D013-LAG R
It's more like I want to select entire row and then paste the data to another worksheet to the columns I want to. I don't want entire row to be pasted as it is.
I don't have much experience in VBA and have already tried doing the code which results in copying of the last record encountered in the loop. Need your advice.
Sub Row_Copy()
Dim sheet1 As Worksheet, sheet2 As Worksheet
Dim i As Integer, k As Integer
Dim Sheet1LR As Long, Sheet2LR As Long
Set sheet1 = Sheets("MASTER")
Set sheet2 = Sheets("DELIVERY")
Sheet1LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheet2LR = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
i = 2
k = Sheet2LR
Do Until i = Sheet1LR
If Trim(sheet1.Cells(i, 26).Value) = "D013-LAG R" Then
With sheet1
.Range(.Cells(i, 1), .Cells(i, 26)).Copy
End With
With sheet2
.Cells(k, 1).PasteSpecial
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
End If
k = k + 1
i = i + 1
Loop
MsgBox (Complete)
ActiveWorkbook.Save
Application.ScreenUpdating = False
End Sub
This is the latest code I am using;
Sub CommandButton1_Click()
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim CopyFromSht As Worksheet
Dim CopyToSht As Worksheet
Dim LCnt As Long
On Error GoTo Err_Execute
Set CopyFromSht = Workbooks("TestRow.xlsm").Sheets("MASTER")
Set CopyToSht = Workbooks("TestRow.xlsm").Sheets("DELIVERY")
With CopyFromSht
'Start search in row 4
LSearchRow = .Range("A" & Rows.Count).End(xlUp).Row
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
For LCnt = 2 To LSearchRow
'If value in column Z = "Unit as needed", copy entire row to Sheet2
If .Range("Z" & LCnt).Value = "D013-LAG R" Then
'Select row in Sheet1 to copy
.Rows(LCnt).Copy Destination:=CopyToSht.Rows(LCopyToRow)
'Move counter to next row
LCopyToRow = LCopyToRow + 1
End If
Next LCnt
End With
I wrote a macro that might give you an idea how to resolve your problem:
Sub CopyRows()
' Variables
Dim row_src As Integer
Dim row_dest As Integer
' Inizialize row within destination sheet
row_dest = 1
' Loop over all rows in source sheet
For row_src = 1 To 32767
' Go to correct cell within source sheet
Sheets("Source").Select
Range("B" & CStr(row_src)).Select
' Done if this row is empty
If (ActiveCell.Value = "") Then
Exit For
End If
' Copy row if it's the header or if match found
If (row_src = 1) Or (ActiveCell.Value = "D013-LAG R") Then
' Copy source row
Rows(CStr(row_src) & ":" & CStr(row_src)).Select
Selection.Copy
' Go to destination row
Sheets("Destination").Select
Rows(CStr(row_dest) & ":" & CStr(row_dest)).Select
' Copy row
ActiveSheet.Paste
' Make sure next row is copied on the right place
row_dest = row_dest + 1
End If
Next
End Sub
In case you want to copy only a few columns from the source to the destination sheet, try this:
' Copy columns B to E of source row
Range("B" & CStr(row_src) & ":E" & CStr(row_src)).Select
Selection.Copy
' Go to destination
Sheets("Destination").Select
Range("B" & CStr(row_dest)).Select
' Copy these columns
ActiveSheet.Paste
In case the columns to be copied are not consecutive (for instance B, D and F):
Range("B" & CStr(row_src) & ",D" & CStr(row_src) & ",F" & CStr(row_src)).Select
Range("F" & CStr(row_src)).Activate
Selection.Copy
By the way, I don't know this all by heart.
You can easily find out the details by executing within Excel:
- Menu View/Macro/Register Macro (or something similar; I got the Italian version)
- Do manually anything you want to automate
- Menu View/Macro/Interrput registration
- Menu View/Macro/View/Modify
I hope this helps you

How to duplicate a row based on column or cell value

I am trying to duplicate rows in excel using VBA and merge columns into one.
The VBA code below hide some columns. i need help edit my code to show all columns(copy col A through col Q).
This is how the original data looks like
This is how i would like to end up to
This is how i get using the code listed below (problem: doesnt show or copy col. B to Col P)
I would like to show all columns between A and Q. the code below hides all columns except the first and merged one(Col A and merged col on col. B).
Sub SortMacro()
Dim SourceSheet As Worksheet
Dim OutSheet As Worksheet
Set SourceSheet = ActiveSheet
Set OutSheet = Sheets.Add
With SourceSheet
Out_i = 1
For r = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
For i = 17 To 20 'or For each i in Array(17,18,20)
OutSheet.Cells(Out_i, 1) = .Cells(r, 1)
OutSheet.Cells(Out_i, 2) = .Cells(r, i)
Out_i = Out_i + 1
Next
Next
End With
End Sub
Thanks!
This is my interpretation of what you need. I've added a loop to copy columns A:P into each new row
Sub SortMacro()
Dim SourceSheet As Worksheet
Dim OutSheet As Worksheet
Set SourceSheet = ActiveSheet
Set OutSheet = Sheets.Add
With SourceSheet
Out_i = 1
For r = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
' Create a new row for each column entry in Q:T
For i = 17 To 20
' Check the cell isn't empty before creating a new row
If (.Cells(r, i).Value <> "") Then
' Copy columns A:P
For j = 1 To 16
OutSheet.Cells(Out_i, j) = .Cells(r, j)
Next j
' Copy the current column from Q:T
OutSheet.Cells(Out_i, 17) = .Cells(r, i)
Out_i = Out_i + 1
End If
Next i
Next r
End With
End Sub