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.
Related
I have been trying to adapt the following code to
Loop through column A of Sheet 1 and for each value in column A search the whole workbook for it's matching value (which will be found in another sheet also in column A). When a match is found, return the value found in the same row but from column F.
Sub Return_Results_Entire_Workbook()
searchValueSheet = "Sheet2"
searchValue = Sheets(searchValueSheet).Range("A1").Value
returnValueOffset = 5
outputValueSheet = "Sheet2"
outputValueCol = 2
outputValueRow = 1
Sheets(outputValueSheet).Range(Cells(outputValueRow, outputValueCol), Cells(Rows.Count, outputValueCol)).Clear
wsCount = ActiveWorkbook.Worksheets.Count
For I = 1 To wsCount
If I <> Sheets(searchValueSheet).Index And I <> Sheets(outputValueSheet).Index Then
'Perform the search, which is a two-step process below
Set Rng = Worksheets(I).Cells.Find(What:=searchValue, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
rangeLoopAddress = Rng.Address
Do
Set Rng = Sheets(I).Cells.FindNext(Rng)
Sheets(outputValueSheet).Cells(Cells(Rows.Count, outputValueCol).End(xlUp).Row + 1, outputValueCol).Value = Sheets(I).Range(Rng.Address).Offset(0, returnValueOffset).Value
Loop While Not Rng Is Nothing And Rng.Address <> rangeLoopAddress
End If
End If
Next I
End Sub
The code above works but only for the first row of data on Sheet1.
Any help would be greatly appreciated!
You can create an array of arrays where each index of main array would be the dataset A:F from each worksheet:
Sub test()
Dim WK As Worksheet
Dim LR As Long
Dim i As Long
Dim j As Long
Dim MasterArray() As Variant
Dim WkArray As Variant
'create master aray
ReDim MasterArray(1 To ThisWorkbook.Worksheets.Count - 1) 'As many indexes as worksheets -1 (because master sheet does not count)
i = 1
For Each WK In ThisWorkbook.Worksheets
If WK.Name <> "Hoja1" Then 'exclude master sheet witch search values
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
WkArray = WK.Range("A1:F" & LR).Value 'take all values in A:F to singlearray
MasterArray(i) = WkArray
Erase WkArray
i = i + 1
End If
Next WK
'now in Master array you have in each index all the values
' as example, if you call MasterArray(1)(1, 1) it will return cell value A1 from first worksheet
Set WK = ThisWorkbook.Worksheets("Hoja1") 'master sheet witch search values
With Application.WorksheetFunction
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
For i = 1 To LR Step 1 'for each row in master sheet until last non blank
For j = 1 To UBound(MasterArray) Step 1 'for each dataset in masterarray
WkArray = Application.Transpose(Application.Index(MasterArray(j), , 1)) 'first column of dataset (A column)
If IsError(Application.Match(WK.Range("A" & i).Value, WkArray, 0)) = False Then 'if value exists get F
WK.Range("B" & i).Value = .VLookup(WK.Range("A" & i).Value, MasterArray(j), 6, 0)
Erase WkArray
Exit For
End If
Erase WkArray
Next j
Next i
End With
Erase MasterArray
Set WK = Nothing
End Sub
The code first creates the main array named MasterArray. Then it loops trough each value on column A from Master Sheet (named Hoja1 in my example) and checks if the value exists in each subarray. If it does then returns columns F from dataset and keep looping.
After executing code I get this output:
Notice value 2 returns nothing because it does not exist in any of the other sheets.
I have a lookup table of data in Sheet1 where all the names in columns A and B will be unique, so no names in either A will exist in B and vice-versa. However, some names could include special characters like a hyphen or dash such as O'neil or Jamie-lee
I have another table of data in Sheet2, in which I need to use the text string in column D to find a matching name in Sheet1 (in either column A or B) and then assign the Score value of the row on sheet1 if a match is found into Sheet2 column E.
I have entered the matched score values in column E to demonstrate the outcome I require.
I don't mind using VBA or an Excel formula that works in XL2010
Is it possible to use a text string to find a word match, as I've only seen it the other way around, or am I looking at this the wrong way? I just don't seem to be getting anywhere.
I have change the code so often now trying to get it to work, I think I'm a bit lost, but this is the current state of my code that isn't working:
Sub TextSearch()
Dim LR As Long
LR = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Dim xLR As Long
xLR = ThisWorkbook.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Dim oSht As Worksheet
Dim Lastrow As Long
Dim strSearch As String, Score As String
Dim aCell As Range
Dim i As Integer
Set oSht = Sheets("Sheet1")
Lastrow = oSht.Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Sheet2")
'Loop from Lastrow to Firstrow (bottom to top)
For Lrow = xLR To 2 Step -1
'Get the value in the D column to perform search on
With .Cells(Lrow, "D")
If Not IsEmpty(.Value) Then
strSearch = .Value
Set aCell = oSht.Range("A1:B" & Lastrow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
For i = 2 To Lastrow
'Lookin column A on sheet1
If oSht.Cells(i, 1).Value = aCell Then
Score = oSht.Cells(i, 1).Offset(0, 2).Value
Sheets("Sheet2").Cells(Lrow, 4).Offset(0, 1).Value = Score
'Lookin Column B on sheet1
ElseIf oSht.Cells(i, 2).Value = aCell Then
Score = oSht.Cells(i, 2).Offset(0, 1).Value
Sheets("Sheet2").Cells(Lrow, 4).Offset(0, 1).Value = Score
End If
Next i
End If
End With
Next Lrow
End With
End Sub
This should do what you are attempting using a dictionary. It creates keys based off of Columns A and B on Sheet 1 with their scores stored as the item.
If you have duplicate names in Sheet 1 this won't fail, but it will only match against the first name encountered. There isn't enough data for it to make a distinction that I can see.
Sub findmatches()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim dict As Object
Dim i As Long
Dim lr As Long
Dim name As String
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set dict = CreateObject("Scripting.Dictionary")
With ws1
lr = .Cells(.Rows.Count, 1).End(xlUp).Row 'Getting last row
For i = 2 To lr
If Not dict.exists(.Cells(i, 1).Value) Then 'Checking if name is in dictionary
dict.Add .Cells(i, 1).Value, .Cells(i, 3).Value 'Adding name and score
End If
If Not dict.exists(.Cells(i, 2).Value) Then 'Checking if name is in dictionary
dict.Add .Cells(i, 2).Value, .Cells(i, 3).Value 'Adding name and score
End If
Next i
End With
With ws2
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
For i = 2 To lr
name = Split(.Cells(i, 4).Value, " ")(0) 'Splitting the string into an array and taking the first element
If dict.exists(name) Then 'Checking if name is in dict
.Cells(i, 5).Value = dict(name) 'assigning score to Column 5
Else
.Cells(i, 5).Value = 0 'No name score = 0
End If
Next i
End With
End Sub
In Excel 365, this is possible via an (extended) array formula. Paste into E2 and copy down.
=LET(lookup,Sheet1!$C$2:$C$5,delimiter," ",string,$D2,array,Sheet1!$A$2:$B$5,data,INDEX(array,MOD(SEQUENCE(ROWS(array)*COLUMNS(array),,0),ROWS(array))+1,ROUNDUP(SEQUENCE(ROWS(array)*COLUMNS(array))/ROWS(array),0)),values,FILTERXML("<t><s>"&SUBSTITUTE(string,delimiter,"</s><s>")&"</s></t>","//s"),list,IFERROR(INDEX(lookup,1+MOD(MATCH(values,data,0)-1,ROWS(array))),0),TRANSPOSE(FILTER(list,list<>0)))
Breaking this down
=LET(lookup, Sheet1!$C$2:$C$5,
delimiter, " ",
string, $D2,
array, Sheet1!$A$2:$B$5,
data, INDEX(array,MOD(SEQUENCE(ROWS(array)*COLUMNS(array),,0),ROWS(array))+1,ROUNDUP(SEQUENCE(ROWS(array)*COLUMNS(array))/ROWS(array),0)),
values, FILTERXML("<t><s>"&SUBSTITUTE(string, delimiter,"</s><s>")&"</s></t>","//s"),
list, IFERROR(INDEX(lookup,1+MOD(MATCH(values,data,0)-1,ROWS(array))),0),
TRANSPOSE(FILTER(list, list<>0))
)
Assign:
lookup as the lookup range to take the values for the results
delimiter and string as the sentence to test and how to split it for a dynamic array
array as the data lookup array to test
data is a calculated 1D array of all values from array stacked
values is a calculated 1D array from your sentence to test
list is then an array of the row 'indices' where matches are found (mod #rows so it's column independent)
Finally, that list is filtered of any non-hits then transposed to give a spill list of all the matches from the lookup values.
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
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
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