I would like to compare 2 columns in the same worksheet, search for non-matching values in column A when compared to column D and copy the entire rows of these non-matching values in column A to another worksheet.
Here is a sample of the worksheet:
Therefore, I would like to compare column A with column D, find the values which do not match and copy the entire corresponding rows from Columns A and B to a new worksheet.
*Edit, I forgot to include my code
Dim CopyToRow As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim found As Range
'Start copying data to row 2 in Sheet2 (row counter variable)
CopyToRow = 2
Set rng1 = Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(2, 1).End(xlDown))
Set rng2 = Range(ActiveSheet.Cells(4, 2), ActiveSheet.Cells(4, 2).End(xlDown))
For Each cell In rng1
Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not found Is Nothing Then
cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)
CopyToRow = CopyToRow + 1
End If
Next cell
Many thanks and much appreciated!
I agree with Ron Rosenfeld that you should have demonstrated your own attempt. That being said, perhaps this will be of some help to you. Not the most elegant but should work provided you update references to your own sheet names.
Sub SOPractice()
Dim SearchCell As Range 'each value being checked
Dim SearchRng As Range 'column A
Dim LastRow As Long
Dim MatchFound As Range
Dim i As Long: i = 1
LastRow = YourSheet.Range("A" & Rows.Count).End(xlUp).Row
With YourSheet
Set SearchRng = .Range(.Cells(2, 1), .Cells(LastRow, 1))
Application.ScreenUpdating = False
For Each SearchCell In SearchRng
Set MatchFound = .Range("D:D").Find _
(What:=SearchCell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If MatchFound Is Nothing Then 'No match hence copy to other sheet
.Range(SearchCell.Address, SearchCell.Offset(, 1)).Copy
YourCopyToSheet.Cells(i, 1).PasteSpecial xlPasteAll
i = i + 1
End If
Next SearchCell
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
I have also found a solution, using a Dictionary object:
Dim Cl As Range, Rng As Range, Dic As Object
Set Dic = CreateObject("scripting.dictionary")
With Dic
For Each Cl In MyWorksheet1Name.Range("D2", MyWorksheet1Name.Range("D" & Rows.Count).End(xlUp))
.Item(Cl.Value) = Empty
Next Cl
For Each Cl In MyWorksheet1Name.Range("A2", MyWorksheet1Name.Range("A" & Rows.Count).End(xlUp))
If Not .Exists(Cl.Value) Then
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
End If
Next Cl
End With
If Not Rng Is Nothing Then
Rng.EntireRow.Copy MyWorksheet2Name.Range("A" & Rows.Count).End(xlUp)
End If
Cheers!
Related
Got a bunch of worksheets in the same workbook that have a specific range of interest that starts with finding string 'Green'. Let's call this Range (A) that I'm interested in copying and pasting into a master sheet to form a database in same workbook. I found some useful code and got this part to work gr8!
There is a date value in each worksheet in cell(3,3). What's missing is adding this date value from each worksheet and past it to column B in the master sheet 'Main' such that the date value extends to match the length of the pasted Range (A).
all help is appreciated
Sub FindRangeHistory()
'// in MainDB workbook for each trade sheet, copy and paste specific range into 'Main' sheet
Dim fnd As String, faddr As String
Dim rng As Range, foundCell As Range
Dim ws As Worksheet
Dim ws_count As Integer, i As Integer
ws_count = ThisWorkbook.Worksheets.Count
For i = 1 To ws_count
With ThisWorkbook
'initialize main sheet and keyword search
Set ws = .Worksheets("Main")
fnd = "New Life"
'Search for keyword in sheet
With .Worksheets(i)
Set foundCell = .Cells.Find(What:=fnd, after:=.Cells.SpecialCells(xlCellTypeLastCell), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Test to see if anything was found
If Not foundCell Is Nothing Then
faddr = foundCell.Address
Set rng = .Range(foundCell, foundCell.End(xlDown))
Do
Set rng = Union(rng, .Range(foundCell, foundCell.End(xlDown)).Resize(, 7))
Set foundCell = .Cells.FindNext(after:=foundCell)
Loop Until foundCell.Address = faddr
Set rng = rng.Offset(1, 0)
rng.Copy
ws.Cells(Rows.Count, "C").End(xlUp).PasteSpecial Paste:=xlPasteValues
Worksheets(i).Cells(3, 3).Copy
ws.Cells(Rows.Count, "B").End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
End With
End With
Next i
End Sub
You could do it like this:
'...
'...
Dim nextRowC As Long, lastRowC As Long
nextRowC = ws.Cells(Rows.Count, "C").End(xlUp).Row + 1 'first empty row in ColC before paste
rng.Copy
ws.Cells(nextRowC, "C").PasteSpecial Paste:=xlPasteValues
lastRowC = ws.Cells(Rows.Count, "C").End(xlUp).Row 'last used row in ColC after paste
.Worksheets(i).Cells(3, 3).Copy
ws.Range(ws.Cells(nextRowC, "B"), ws.Cells(lastRowC, "B")). _
PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'...
'...
I am trying to copy & transpose values from one Sheet to another Sheet based on a condition, only transpose the first 4 lines looping in large range.
From this:
To this :
I've found a transpose macro and adapt it but I couldn't apply the condition.
Sub Test()
Set rng = Range("B5", Range("B5").End(xlDown))
Sheets("Example #2").Range(rng).Value = WorksheetFunction.Transpose()
EndSub
Anyone can guide me? Any help would be greatly appreciated!
Please, test the next code. It uses arrays, works in memory and will be much faster than copying. This can be easier observed on a large range:
Sub CopyTranspose4rows()
Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, arr, arrSl, i As Long
Set sh1 = ActiveSheet 'use here the sheet you need to copy from
Set sh2 = sh1.Next 'use here what sheet you need to paste
lastR = sh1.Range("B" & sh1.rows.count).End(xlUp).row 'last row sh1
arr = sh1.Range("B5:B" & lastR).Value 'put the range in an array for fast iteration
For i = 1 To UBound(arr) Step 4 'iterate from four to four
With Application
'create a slice array
arrSl = .Transpose(.Index(arr, Evaluate("row(" & i & ":" & i + 4 & ")"), 1))
End With
'drop the slice array content in the second sheet
sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1).Resize(1, 4).Value = arrSl
Next i
sh2.Activate 'activate the sheet where pasted
End Sub
#FaneDuru's array solution is more elegant, but here's another alternative. You would need to replace the sheet names and the starting cell numbers.
Sub TestTranspose()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LR1 As Long
Dim x As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
LR1 = sht1.Cells(Rows.Count, 2).End(xlUp).Row
y = 1
For x = 1 To LR Step 4
sht1.Range(sht1.Cells(x, 2), sht1.Cells(x + 3, 2)).Copy
sht2.Cells(y, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
y = y + 1
Next x
End Sub
With this code you can have different number of answers per question.
Sub Tranpose_Questions()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim transRng As Range ' range to transpose
Dim dstRng As Range: Set dstRng = ActiveSheet.Range("C1") ' destination cell
' Value find
fnd = "Question"
Set myRange = ActiveSheet.Range("A1", Range("A1").End(xlDown))
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
' Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo errHandler
End If
Set rng = FoundCell
' Loop
Do Until FoundCell Is Nothing
' Find next cell
Set FoundCell = myRange.FindNext(after:=FoundCell)
Debug.Print rng.Address, FoundCell.Address
' Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then
Set transRng = Range(rng, rng.End(xlDown))
If rng.Offset(1, 0) <> "" Then
transRng.Select: transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End If
Exit Do
End If
' Transpose
Set transRng = rng.Resize(FoundCell.Row - rng.Row, 1)
transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
' update rng position
Set rng = FoundCell
' update destination range
Set dstRng = dstRng.Offset(1, 0)
Loop
Exit Sub
' Error Handler
errHandler:
MsgBox "No 'Question' found!"
End Sub
I have a workbook with 2 sheets.
Sheet1 contains a list of Product Codes in column A and Column R is Current Stock Level.
Sheet2 contains a list of Product Codes in column A and Column B contains the New Stock Level.
What I want to do is replace the Current Stock Levels in Sheet1 with the New Stock Level from Sheet2.
I found some code on this site already (below) which I have adapted slightly for my purpose and it works fine but only for one Product Code (as it references A1 and B1). What I would like to do is add a Loop so it works down all products in Sheet2 but I'm not sure how to and haven't been able to adapt any similar loops I've found online for this purpose.
Any help would be appreciated, my backup plan is to just do a v-lookup in Sheet1 to bring in the Sheet2 New Stock Level values and then replace the original column but I would like to get this other way working if possible.
Private Sub CommandButton1_Click()
Dim search_range As Range, search_value As Range, _
lastcell As Range, foundcell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set search_range = ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
Set lastcell = search_range.Cells(search_range.Cells.Count)
Set search_value = ThisWorkbook.Sheets("Sheet2").Range("A1")
Set foundcell = search_range.Find(What:=search_value, After:=lastcell,
LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not foundcell Is Nothing Then foundcell.Activate Else MsgBox "Not Found"
ActiveCell.Offset(0, 17).Value = Sheets("Sheet2").Range("B1").Value
End Sub
How about the following:
Private Sub CommandButton1_Click()
Dim search_range As Range, search_value As Range, lastcell As Range, foundcell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set search_range = ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
Set lastcell = search_range.Cells(search_range.Cells.Count)
For i = 1 To lastcell.Row
Set search_value = ThisWorkbook.Sheets("Sheet2").Range("A" & i)
Set foundcell = search_range.Find(What:=search_value, After:=lastcell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not foundcell Is Nothing Then foundcell.Activate Else MsgBox "Not Found"
ActiveCell.Offset(0, 17).Value = Sheets("Sheet2").Range("B" & i).Value
Next i
End Sub
The idea is the following - you have two types of ranges - ranges where you search and ranges where your value should be. They are called Target and Search.
In the code below you loop through all cells in column A of the first worksheets and you look for their value in column A of the second worksheet. If you find the value, you write the value in column B of the second worksheet to the 17. column in the first worksheet:
Private Sub CommandButton1_Click()
Dim targetRange As Range
Dim targetValue As Range
Dim searchRange As Range
Dim lastSearchCell As Range
Dim foundCell As Range
Dim wsTarget As Worksheet
Dim wsSearch As Worksheet
Dim myCell As Range
Set wsTarget = ThisWorkbook.Worksheets(1)
Set wsSearch = ThisWorkbook.Worksheets(2)
With wsTarget
Set targetRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
With wsSearch
Set searchRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
Set lastSearchCell = searchRange.Cells(searchRange.Cells.Count)
For Each myCell In targetRange
Set foundCell = searchRange.Find(What:=myCell, After:=lastSearchCell).Offset(0, 1)
If Not foundCell Is Nothing Then
myCell.Offset(0, 17) = foundCell
Else
MsgBox "Not Found"
End If
Next myCell
End Sub
I have source data which are not aligned to table.
I want to find text (e.g. Account), copy the two whole lines below the cell with the found text (Account) and paste them on a different Sheet. Then search down and do again until the data ends. Data should be pasted in the order it is reached.
The cell with word "Account" will be always in the column A. The search should be for the exact word "Account", because in the column can be cells which contain e.g. "Payer account".
This code shows me an error msg
"Run-time error 438 - object doesnt support this property or method"
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, C As Range
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Account" Then
C.Offset(-1, 0).Copy C.Offset.OUTPUT_2(-7, -1) ' use offset to put value in sheet "Output_2", column E
End If
Next C
End With
End Sub
This post doesn't point out what the error in your original code is. Ron Rosenfeld has already covered that in the comment.
Here is another faster way (as compared to looping) which uses .Find/.FindNext to achieve what you want. It also doesn't copy the rows in a loop but copies in the end.
Private Sub Search_n_Copy()
Dim ws As Worksheet
Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
strSearch = "Account"
Set ws = Worksheets("INPUT_2")
With ws
Set aCell = .Columns(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bcell = aCell
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Do
Set aCell = .Columns(1).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bcell.Address Then Exit Do
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
'~~> I am pasting to Output sheet. Change as applicable
If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Rows(1)
End With
End Sub
Screenshot
The codle would be like this. This code Use variant.
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, C As Range
Dim vR(), n As Long, k As Integer, j As Integer
Dim Ws As Worksheet
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
.Columns("e").ClearContents
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Account" Then
For j = 1 To 2
n = n + 1
ReDim Preserve vR(1 To 6, 1 To n)
For k = 1 To 6
vR(k, n) = C.Offset(j, k - 1) ' use offset to put value in sheet "Output_2", column E
Next k
End If
Next C
If n > 0 Then
Set Ws = Sheets.Add '<~~~ Sheets("your sheet name")
With Ws
.Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(vR)
End With
End If
End With
End Sub
I have a bunch of column of rows that contain text such as:
dog,cat,mouse
bat,dog,fly
fish,beaver,horse
I'm trying to search and highlight rows that contain certain word:
Public Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Dim LR As Long
Dim vVal
Dim tRow
LR = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B1:B" & LR)
iWarnColor = xlThemeColorAccent2
For Each rngCell In rng.Cells
tRow = rngCell.Row
If InStr(rngCell.Value, "dog") = 1 Then
rngCell.Interior.ColorIndex = iWarnColor
Else
rngCell.Interior.Pattern = xlNone
End If
Next
End Sub
This works fine so long as the word 'dog' is the first word in the comma string, so it would highlight the first row but not row two because the word 'dog' appears after 'bat'. Do I need to strip the commas out first or is there a better way of doing this?
It looks like your ultimate goal is to color the row based on whether or not 'dog' is in a cell. Here's a different way to do it that doesn't even involve VBA (this example assumes your data is all in column A):
Make a new column to the right. Use the formula =IF(NOT(ISERROR(FIND("dog",A1))),1,0). You can hide the column later so the user doesn't see it. Basically, if it has the word 'dog' somewhere, then return 1 else 0.
Select the entire first row
Under Conditional Formatting, go to New Rule
Choose Use a Formula
For your formula, try =$B2=1
Now that you've conditionally colored one row, copy and paste format to the other rows.
All rows should now update automatically.
Extra Credit: If this data is formatted as a table object, the conditional formatting should automatically carry over to new rows as they are added.
Further to my comments above
Example 1 (Using .Find and .Findnext)
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range, bCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
rng.Interior.ColorIndex = xlNone
Set aCell = rng.Find(What:="dog", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = iWarnColor
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = iWarnColor
Else
Exit Do
End If
Loop
End If
End With
End Sub
Screenshot
Example 2 (Using Autofilter)
For this ensure that there is a Heading in Cell B1
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
'~~> Remove any filters
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
With rng
.AutoFilter Field:=1, Criteria1:="=*dog*"
Set aCell = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
If Not aCell Is Nothing Then aCell.Interior.ColorIndex = iWarnColor
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub