Search match twice 2 keywords same column and copy result to another sheet - excel

I am stuck i don't know what code to use so i can search the same column twice for 2 different keyword and then copy data from the same row to another spreadsheet in sequence from a start cell. for details here's what i am trying to do.
Limit the search within a range of the worksheet (ex. Sheet 1 B1:N:200)
Search the 8th column (I) of the limit range Sheet1 for keyword ("Goods")
Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Goods " is found
Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) on a specific starting point (ex. Sheet 2 - B3) Next Match Result will be Sheet 2 - B4 and so on
5.Search AGAIN the 8th column of Sheet1 for keyword ("Services") starting from the top (B1:N1)
6.Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Services" is found
Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) to next row after the last PASTE from "Goods" was done. (ex last row match paste was C35 and D35 new found value should be paste in C36 a D36)
Ending Output should be all "Goods" results first then "Services" results
I hope i have conveyed what i need clearly
I am trying to work on this code that i found here but i just don't get how to insert the 2nd search loop for services., how to paste on specific cell in sheet2, how to follow the last row for services paste
Sub CopyCells
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If Sheets(1).Range("" & (counterSht1)).Value = "Goods" Then
Sheets(2).Range("B" & (counterSht2), "D" & (counterSht2)).Value = Sheets(1).Range("C" & counterSht1, "D" & counterSht1).Value
End If
Next counterSht2
Next counterSht1
End With
End Sub
Edit1
As per request of sir Chris this is how it should look like
Answer for this Query was best solved by #CDP1802 Worked as needed.
I learned that I needed 2 counters for it to work :) and I also learned how to properly label target destination.
Thank you for this community:)

Increment the target row after each copy.
Option Explicit
Sub CopyCells()
Const ROW_START = 3
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim n As Long, r As Long, lastrow1 As Long, lastrow2 as Long
Dim keywords, word, t0 As Single: t0 = Timer
keywords = Array("Goods", "Services")
Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
lastrow2 = ROW_START
Application.ScreenUpdating = False
With ws1
lastrow1 = .Cells(.Rows.Count, "I").End(xlUp).Row
For Each word In keywords
For r = 1 To lastrow1
If Len(.Cells(r, "I")) = 0 Then
Exit For
ElseIf .Cells(r, "I") = word Then
'Sht1 col 2 to Sht2 Col 3 (no format values only)
'Sht1 col 5 to Sht2 Col 4 (with format and values)
ws2.Cells(lastrow2, "C") = .Cells(r, "B")
ws2.Cells(lastrow2, "D") = .Cells(r, "E")
.Cells(r, "E").Copy
ws2.Cells(lastrow2, "D").PasteSpecial xlPasteFormats
lastrow2 = lastrow2 + 1
n = n + 1
End If
Next
Next
End With
Application.ScreenUpdating = True
MsgBox r - 1 & " rows scanned " & vbLf & n & " rows copied", _
vbInformation, Format(Timer - t0, "0.0 secs")
End Sub

You could make two routines: one for services and one for goods. But that code and the code above isn't very efficient.
Since Services & Goods are in the same column, try using the autofilter:
Sheets(2).UsedRange.autofilter Field:=8, Criteria1:=Array("Goods", "Services"), VisibleDropDown:=False, Operator:=xlFilterValues
Sheets(2).UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets(1).Range("A1").PasteSpecial
Application.CutCopyMode = False

Related

How to delete all rows from sheet1 which is not in sheet2

friends I have Two Excel Sheets which is shown below...
**Sheet_1** **Sheet_2**
ID Name Address ID Name Address
1 A Any 2 B Any
2 B Any 4 D Any
3 C Any 5 E Any
4 D Any
5 E Any
I want to delete all rows from Sheet_1 which is not in Sheet_2.
Note: ID of sheets is unique
I'm not sure if I got this right, but you want to delete rows that are not in Sheet2?
So that would make your Sheet1 to be a copy of Sheet2, wouldn't it?
Well, anyways, here is the code of the main Sub:
Sub Main()
Set idsToExclude = CreateObject("Scripting.Dictionary"): idsToExclude.CompareMode = TextCompare
'fill dictionary with IDs from sheet 2
Set idsToExclude = CreateDictFromColumns("Sheet2", "A", "B")
'find last populated row
xEndRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'iterate all rows from bottom to top
For i = xEndRow To 2 Step -1
'get value of cell at current row and 1st column
currentCellValue = ActiveSheet.Cells(i, 1).Value
'if row doesnt met criteria, delete it
If Not idsToExclude.Exists(currentCellValue) Then
Rows(i).Delete
End If
Next
End Sub
And the Function to get the Ids and names from a specific Sheet:
Function CreateDictFromColumns(sheet As String, keyCol As String, valCol As String) As Object
Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = TextCompare
Dim rng As Range
Dim i As Long
Dim lastCol As Long '// for non-adjacent ("A:ZZ")
Dim lastRow As Long
lastRow = Sheets(sheet).Range(keyCol & Sheets(sheet).Rows.Count).End(xlUp).Row
Set rng = Sheets(sheet).Range(keyCol & "1:" & valCol & lastRow)
lastCol = rng.Columns.Count
For i = 2 To lastRow
If (rng(i, 1).Value = "") Then Exit Function
dict.Add rng(i, 1).Value, rng(i, lastCol).Value
Next
Set CreateDictFromColumns = dict
End Function
Note: If you want to make the contrary (delete IDs in Sheet1 that are in Sheet2), just remove the Not Operator from the following line:
If Not idsToExclude.Exists(currentCellValue) Then
As you can see, some parts are hard-coded. My suggestion is to adapt those parts and make it more dynamical, I had to write it like that due to lack of details in question.

Attempting copy paste cells from one sheet to another?

I am attempting to copy column B from sheet called "Activity Overview" (Only filled cells) and paste in a sheet called "V&VFile" in column E from row 11 onwards, however when i run the macro the cells arent copied and seems to paste blank cells.
The source of the data uses excel formula index match, is this why as it can copy the data as its found from an excel formula?
Sub VVfileFILL()
Dim Lastrow As Double
Lastrow = Worksheets("Activity Overview").Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Worksheets("Activity Overview").Range("B" & Lastrow).Copy
ThisWorkbook.Sheets("V&V").Range("E" & Rows.Count).End(xlUp).Offset(10, 0).PasteSpecial xlPasteValues
End Sub
Don't think one can avoid a loop in this situation.
Sub VVfileFILL()
Dim Lastrow As Long, r As Long, n As Long
n = Worksheets("V&V").Range("E" & Rows.Count).End(xlUp).Offset(10, 0).Row
With Worksheets("Activity Overview")
Lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
For r = 2 To Lastrow
If Len(.Cells(r, "B")) > 0 Then 'check not blank
If WorksheetFunction.CountIf(Worksheets("V&V").Range("E1:E" & n), .Cells(r, "B")) = 0 Then 'check not already in E
Worksheets("V&V").Cells(n, "E").Value = .Cells(r, "B").Value 'transfer value
n = n + 1 'add 1 to destination row
End If
End If
Next r
End With
End Sub

Insert one row between groups based on criteria in a column

I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub

Need help to optimize the Excel VBA code that aggregates duplicates

Below is my source table
Name Sales
---------------------------------
Thomas 100
Jay 200
Thomas 100
Mathew 50
Output I need is as below
Name Sales
---------------------------------
Thomas 200
Jay 200
Mathew 50
Basically, I have 2 columns that can have duplicates and I need to aggregate the second column based on first column.
Current code I have is as below. Its working perfectly fine. It takes around 45 seconds to run for 4500 records. I was wondering if there is a more efficient way to do this... as it seems to be a trivial requirement.
'Combine duplicate rows and sum values
Dim Rng As Range
Dim LngRow As Long, i As Long
LngLastRow = lRow 'The last row is calculated somewhere above...
'Initializing the first row
i = 1
'Looping until blank cell is encountered in first column
While Not Cells(i, 1).Value = ""
'Initializing range object
Set Rng = Cells(i, 1)
'Looping from last row to specified first row
For LngRow = LngLastRow To (i + 1) Step -1
'Checking whether value in the cell is equal to specified cell
If Cells(LngRow, 1).Value = Rng.Value Then
Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + Cells(LngRow, 2).Value
Rows(LngRow).Delete
End If
Next LngRow
i = i + 1
Wend
Note that this is part of a larger excel app and hence I definitely need the solution to be in Excel VBA.
Here you go:
Option Explicit
Sub Consolidate()
Dim arrData As Variant
Dim i As Long
Dim Sales As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime
Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening
'First of all, working on arrays always speeds up a lot the code because you are working on memory
'instead of working with the sheets
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
arrData = .Range("A2", .Cells(i, 2)).Value 'here im assuming your row 1 has headers and we are storing the data into an array
End With
'Then we create a dictionary with the data
For i = 1 To UBound(arrData) 'from row 2 to the last on Q1 (the highest)
If Not Sales.Exists(arrData(i, 1)) Then
Sales.Add arrData(i, 1), arrData(i, 2) 'We add the worker(Key) with his sales(Item)
Else
Sales(arrData(i, 1)) = Sales(arrData(i, 1)) + arrData(i, 2) 'if the worker already exists, sum his sales
End If
Next i
'Now you have all the workers just once
'If you want to delete column A and B and just leave the consolidate data:
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
.Range("A2:B" & i).ClearContents
.Cells(2, 1).Resize(Sales.Count) = Application.Transpose(Sales.Keys) 'workers
.Cells(2, 2).Resize(Sales.Count) = Application.Transpose(Sales.Items) 'Their sales
End With
Application.ScreenUpdating = True 'return excel to normal
End Sub
To learn everything about dictionaries (and more) check this
With data in cols A and B like:
Running this short macro:
Sub KopyII()
Dim cell As Range, N As Long
Columns("A:A").Copy Range("C1")
ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1")
Range("D2:D" & N).Formula = "=SUMPRODUCT(--(A:A= C2),(B:B))"
End Sub
will produce this in cols C and D:
NOTE:
This relies on Excel's builtin RemoveDuplicates feature.
EDIT#1:
As chris neilsen points out, this function should be a bit quicker to evaluate:
Sub KopyIII()
Dim cell As Range, N As Long, A As Range, C As Range
Set A = Range("A:A")
Set C = Range("C:C")
A.Copy C
C.RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1") ' the header
Range("D2:D" & N).Formula = "=SUMIFS(B:B,A:A,C2)"
End Sub

How to delete the rows based in excel sheet using column values

I have excel with 5 different sheets.
sheet3 and sheet4 i want delete rows based on the single column cell value.
in sheet 3 i want to delete rows based on H column cell values if H2="#N/A" and H503="#N/A" then delete entire rows.
in sheet 4 i want to delete rows based on b column cell values if B2="320857876",B3="32085678",B4="12133435" the delete the entire rows where B column cell values starts with 302.
and i want to delete all Data from 'C' column
My excel sheet is like this
Using excel file
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i) = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
You've got a few requirements there and your code is fairly light but regarding the #N/A part of it, you can't just test for that text using the value approach, which is the default property returned for a range object.
Sub Create()
Dim LastRow As Long, i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i).Text = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
... you need to use .Text to get that to work, or, If IsError(Range("B" & i)) Then is another approach.
The rest of your requirements is just logic. The rest of your code is relatively sound so you just need to work through it.
I hope that helps.
Sub delete_rows()
Dim sheet As Worksheet, cell As Range
Count = 1
For Each sheet In ThisWorkbook.Worksheets
If Count = 3 Then
lastrow = sheet.Cells(sheet.Rows.Count, "H").End(xlUp).Row
Set Rng = sheet.Range("H1:H" & lastrow)
For i = Rng.Cells.Count To 1 Step -1
If Application.WorksheetFunction.IsNA(Rng(i).Value) Then
Rng(i).EntireRow.Delete
ElseIf Rng(i).Value = "#NA" Then
Rng(i).EntireRow.Delete
End If
Next
ElseIf Count = 4 Then
lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).Row
Set Rng = sheet.Range("B1:B" & lastrow)
Debug.Print (Rng(4).Text)
If Rng(2).Value = "320857876" And Rng(3).Value = "32085678" And Rng(4).Value = "12133435" Then
For i = Rng.Cells.Count To 1 Step -1
If Left(Rng(i).Value, 3) = "302" Then
Rng(i).EntireRow.Delete
End If
Next
End If
lastrow = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row
Set Rng = sheet.Range("C1:C" & lastrow)
For Each cell In Rng
cell.Value = ""
Next cell
End If
Count = Count + 1
Next
End Sub

Resources