I have an excel workbook where I want to find the cell that contains "A0_" & A where A is the value from another worksheet. The end goal is to copy the column with "A0_" & A to another sheet titled. Here is my code so far.
Sub Copy_A()
Dim A As String
Dim iRng As Range
Dim cel As Range
Dim dataws As Worksheet
Dim Rng1, Rng2, Rng3, NewRng As Range
Set dataws = Worksheets("Data Importation Sheet")
Set iRng = dataws.Range(dataws.Cells(1, 1), dataws.Cells(1, dataws.Cells(1, Columns.Count).End(xlToLeft).Column))
A = Worksheets("Information Sheet").Range("E12").Value
For Each cel In iRng
If cel.Value = "A0_" & A Then
Set Rng1 = cel.EntireColumn.Find(What:="", LookIn:=xlValues, lookat:=xlPart)
Debug.Print Rng1.FormulaR1C1
Set Rng2 = dataws.Cells(Rng1.Row - 1, Rng1.Column + 1)
Debug.Print Rng2.FormulaR1C1
Set Rng3 = Cells(cel.Row + 1, cel.Column)
Debug.Print Rng3.FormulaR1C1
End If
Next cel
With dataws
Set NewRng = .Range(Rng3.Address & ":" & Rng1.Address)
Debug.Print NewRng.Address
NewRng.Select
End With
End Sub
For some reason the code does not recognize "A0_" & A when it reaches that cell. The code goes through each column but does not execute setting the ranges. Any tips/help would be greatly appreciated! Here is a picture of my workbook to give you a better idea of what is happening
Related
Instead of hard coding the value to be looked up ("1234"), I would like to use a range of values, on a separate worksheet("Items") to use as the search criteria.
I would also like to substitute that same value for the destination sheet.
For example, the first value in the range could be "8754", I would like the code to look for this value then paste the columns, A,B,C,F and the cell containing the value onto the worksheet "8754". (I have all of the worksheets created already)
TIA
Sub Test()
Dim Cell As Range
With Sheets("Sheet1") 'Sheet with data to check for value
For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
pos = InStr(Cell.Value, "1234")
If pos > 0 Then
NextFreeRow = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count,
"A").End(xlUp).Row + 1
'get the next empty row to paste data to
.Range("A" & Cell.Row & ",B" & Cell.Row & ",C" & Cell.Row & ",F" &
Cell.Row & "," & Cell.Address).Copy Destination:=Sheets("Sheet2").Range("A" & NextFreeRow)
End If
Next Cell
End With
End Sub
This uses FIND rather than FILTER to copy the correct rows.
The Main procedure defines the range you're searching and which values will be searched for. The FindValues procedure finds the value and copies it to the correct sheet.
This assumes that Sheet3!A1:A3 contains a unique list of values to be searched for and the these values can be found in Sheet1!H:H.
It also assumes that all sheets already exist.
Public Sub Main()
Dim rToFind As Range
Dim rValue As Range
Dim rSearchRange As Range
With ThisWorkbook
'Update to the range being searched.
With .Worksheets("Sheet1")
Set rSearchRange = .Range("H1", .Cells(.Rows.Count, 8).End(xlUp))
End With
'Update to the range containing the values to be searched for.
Set rToFind = .Worksheets("Sheet3").Range("A1:A3")
End With
'Passe each of the values to be searched to the FindValues procedure.
For Each rValue In rToFind
FindValues rValue, rSearchRange
Next rValue
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Alternative method to look for hard-coded values.
' `ValuesToFind` in FindValues procedure will needed changing to a Variant.
'
' Dim vAlternativeSearch As Variant
' Dim vAlternativeValue As Variant
' vAlternativeSearch = Array(1475, 1683, 219)
'
' For Each vAlternativeValue In vAlternativeSearch
' FindValues vAlternativeValue, rSearchRange
' Next vAlternativeValue
End Sub
Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)
Dim rFound As Range
Dim sFirstAddress
Dim rLastUsedCell As Range
'Find the next available row on the referenced sheet.
With ThisWorkbook.Worksheets(CStr(ValueToFind))
Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
End With
With RangeToSearch
'Find the first value.
Set rFound = .Find(What:=ValueToFind, _
After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
LookAt:=xlPart, _
SearchDirection:=xlNext)
'If the first value exists then remember the address, copy the cells to the
'correct sheet and look for the next row with the same value. Stop when
'it reaches the first address again.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
'You may have to muck around with this to get the correct range to copy.
'If rFound is in column H this will copy columns B:D and F.
Union(rFound.Offset(, -6).Resize(, 3), rFound.Offset(, -2)).Copy Destination:=rLastUsedCell
Set rLastUsedCell = rLastUsedCell.Offset(1)
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Edit 1:
You say the worksheets already exists, but in your comment you say put it in a brand new sheet.
To add a new sheet add this function:
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
and then add this code directly after the variable declaration in the FindValues procedure:
Dim wrkSht As Worksheet
If Not WorkSheetExists(CStr(ValueToFind)) Then
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = CStr(ValueToFind)
End If
Edit 2:
This updated code searches columns Q:Z, returns the values from A:L as well as the found cell.
To update from the original code I had to change rSearchRange to look from Q1 to column 26, and update the Copy/Paste line to return the correct range.
Public Sub Main()
Dim rToFind As Range
Dim rValue As Range
Dim rSearchRange As Range
With ThisWorkbook
'Update to the range being searched.
With .Worksheets("Data")
Set rSearchRange = .Range("Q1", .Cells(.Rows.Count, 26).End(xlUp))
End With
'Update to the range containing the values to be searched for.
Set rToFind = .Worksheets("Items").Range("A1:A2")
End With
'Passe each of the values to be searched to the FindValues procedure.
For Each rValue In rToFind
FindValues rValue, rSearchRange
Next rValue
End Sub
Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)
Dim rFound As Range
Dim sFirstAddress
Dim rLastUsedCell As Range
'Find the next available row on the referenced sheet.
With ThisWorkbook.Worksheets(CStr(ValueToFind))
Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
End With
With RangeToSearch
'Find the first value.
Set rFound = .Find(What:=ValueToFind, _
After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
LookAt:=xlPart, _
SearchDirection:=xlNext)
'If the first value exists then remember the address, copy the cells to the
'correct sheet and look for the next row with the same value. Stop when
'it reaches the first address again.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
'Parent of RangeToSeach range which will be the Data worksheet.
With .Parent
'Copy columns A:L (columns 1 to 12) and the found cell.
Union(.Range(.Cells(rFound.Row, 1), .Cells(rFound.Row, 12)), rFound).Copy Destination:=rLastUsedCell
End With
Set rLastUsedCell = rLastUsedCell.Offset(1)
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Option Explicit
Public Sub Test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, lr1 As Long, lr2 As Long
Dim luArr As Variant, luVal As Variant, r As String, itm As Variant, itmRow As Long
Set ws1 = ThisWorkbook.Worksheets("Data") 'Sheet with data to check for value
Set ws3 = ThisWorkbook.Worksheets("Items") 'LookUp values
luArr = ws3.UsedRange.Columns("A") 'LookUp column
lr1 = ws1.Cells(ws1.Rows.Count, "H").End(xlUp).Row
Dim findRng As Range, copyRng As Range, toRng As Range, fr As Long
Set findRng = ws1.Range("H1:H" & lr1)
On Error Resume Next 'Expected error: sheet not found
Application.ScreenUpdating = False
For Each luVal In luArr
Set ws2 = Nothing
Set ws2 = ThisWorkbook.Worksheets(luVal) 'Copy to
If ws2 Is Nothing Then
Err.Clear
Else
itm = Application.Match(luVal, findRng, 0)
If Not IsError(itm) Then
findRng.AutoFilter Field:=1, Criteria1:="*" & luVal & "*"
fr = IIf(findRng.SpecialCells(xlCellTypeVisible).Cells.Count = 1, 1, 2)
With ws1.UsedRange
Set copyRng = .Range("A" & fr & ":C" & lr1)
Set copyRng = Union(copyRng, .Range("F" & fr & ":F" & lr1))
Set copyRng = Union(copyRng, .Range("H" & fr & ":H" & lr1))
End With
lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
copyRng.Copy
ws2.Cells(lr2, 1).PasteSpecial
findRng.AutoFilter
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet1
Items
Before (Sheet A1, A2, and A3)
After
I have the following code that works but I need to add another criteria to it. The criteria I need to add is a wildcard search for *Utilities. So if column L has the word utilities, then include the row in the copy and paste. If not, do not copy and paste.
Sub CopyData()
Dim Cl As Range
Dim SrcWbk As Workbook
Dim SrcSht As Worksheet
Dim DestSht As Worksheet
Dim Rng As Range
Application.ScreenUpdating = False
Set SrcWbk = Workbooks.Open("Transactional Activity PD 10-2017 (Expense
Accounts).xlsb")
Set SrcSht = SrcWbk.Sheets("Activity")
Set DestSht = ThisWorkbook.Sheets("Transactions")
With CreateObject("scripting.dictionary")
For Each Cl In DestSht.Range("AE2", DestSht.Range("AE" &
Rows.Count).End(xlUp))
If Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
Next Cl
For Each Cl In SrcSht.Range("AE2", SrcSht.Range("AE" &
Rows.Count).End(xlUp))
If Not .exists(Cl.Value) And Cl.Offset(, -29).Value = "PV" And
Cl.Offset(, -15) Like "*Utilities" Then
If Rng Is Nothing Then
Set Rng = Cl
Else
Set Rng = Union(Rng, Cl)
End If
End If
Next Cl
End With
Rng.EntireRow.Copy DestSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
End Sub
THANKS!
The following adds a criteria of only including rows where "utilities" is found in column L of the same row as the test being performed on column AE. Not tested.
Dim Cl As Range
Dim SrcWbk As Workbook
Dim SrcSht As Worksheet
Dim DestSht As Worksheet
Dim Rng As Range
Application.ScreenUpdating = False
Set SrcWbk = Workbooks.Open("Transactional Activity PD 10-2017 (Expense Accounts).xlsb")
Set SrcSht = SrcWbk.Sheets("Activity")
Set DestSht = ThisWorkbook.Sheets("Transactions")
With CreateObject("scripting.dictionary")
For Each Cl In DestSht.Range("AE2", DestSht.Range("AE" & Rows.Count).End(xlUp))
If Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
Next Cl
For Each Cl In SrcSht.Range("AE2", SrcSht.Range("AE" & Rows.Count).End(xlUp))
If Not .exists(Cl.Value) And Cl.Offset(, -29).Value = "PV" And _
InStr(Cl.Offset(, -19), "utilities") > 0 Then
If Rng Is Nothing Then
Set Rng = Cl
Else
Set Rng = Union(Rng, Cl)
End If
End If
Next Cl
End With
Rng.EntireRow.Copy DestSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
End Sub
I have the following code, which is technically a nested loop
Dim compareRange As Range
Dim toCompare As Range
Dim rFound As Range
Dim cel As Range
Set compareRange = Worksheets("sheet2").Range("A2:A" & Lastrow3)
Set toCompare = Worksheets("sheet3").Range("A2:A" & Lastrow4)
Set rFound = Nothing
For Each cel In toCompare
Set rFound = compareRange.Find(cel)
How do I find which row the value was found in a separate sheet? For instance if AAAA was in row 1 on sheet3 and it was found on row 5 of sheet2 how do I retrieve the value 5 for row 5?
FIND returns a reference to the cell. From that reference you gain access to all the properties of the cell, the same way you would if you manually set a reference to it.
Use FINDNEXT or FINDPREVIOUS to move to the next or previous instance of a found item.
The code below shows how to return various values from each found item:
Sub Test()
Dim compareRange As Range
Dim toCompare As Range
Dim rFound As Range
Dim cel As Range
Dim FirstAddress As String
Dim LastRow3 As Long
Dim LastRow4 As Long
LastRow3 = 189: LastRow4 = 9
Set compareRange = Worksheets("sheet2").Range("A2:A" & LastRow3)
Set toCompare = Worksheets("sheet3").Range("A2:A" & LastRow4)
With compareRange
For Each cel In toCompare
'Find the first instance of cel.
Set rFound = .Find(cel)
'Check that rFound contains a value otherwise an error will occur when
'trying to return values from it.
If Not rFound Is Nothing Then
FirstAddress = rFound.Address
Do
With rFound
Debug.Print "Row: " & .Row & " - Col: " & .Column & _
" - Sheet: " & .Parent.Name & " - Book: " & .Parent.Parent.Name
End With
'Find the next instance of cel.
Set rFound = .FindNext(rFound)
Loop While FirstAddress <> rFound.Address
End If
Next cel
End With
End Sub
https://msdn.microsoft.com/VBA/Excel-VBA/articles/range-find-method-excel
https://msdn.microsoft.com/VBA/Language-Reference-VBA/articles/with-statement
I have used a variable named rng as Range.
I have found the last row by using:
lastrow = tmpSheet.Cells(tmpSheet.Rows.Count, "A").End(xlUp).Row
& after finding a word in a Foundcell(Range format) using:
Set Foundcell = tmpSheet.Range("A2:A" & lastrow).Find(What:="ABC")
Do Until Foundcell Is Nothing
Set rng = tmpSheet.Range(Cells(1, 1), Cells(lastrow, 1))
.
.
(Copy the row from a aheet to another)
.
.
errHandler:
End Sub
After getting the value in Foundcell the control goes to End Sub directly from the line "Set rng" . I am not getting Why it's happening ?
If you are getting the range Cells(1,1) to Cells(lastrow,1) on tmpsheet, you should change the Set Rng line to:
Set rng = Range(tmpSheet.Cells(1,1), tmpSheet.Cells(lastrow,1))
instead.
You did not supply the entire code, but this is probably what you are looking for.
Sub Button1_Click()
Dim tmpSheet As Worksheet
Dim PasteSH As Worksheet
Dim lastrow As Long
Dim rng As Range
Dim c As Range
Set tmpSheet = Sheets("Sheet1")
Set PasteSH = Sheets("Sheet2")
With tmpSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & lastrow)
End With
For Each c In rng.Cells
If c = "ABC" Then
c.EntireRow.Copy PasteSH.Cells(PasteSH.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
End Sub
I have created macro that works like a vlookup but has split values. I would like to find value from second sheet of split values (separated by semicolon ) and copy and paste the description to new sheet.
The first loop goes through the list in sheet 2 and sets the value in a variable, the second loop through split values checks when there is exact match and the description is copied and pasted to the second sheet.
However - it doesn't work and I don't know what the problem is.
I have notification "type mismatch".
I tried vlookup with part text string but it doesn't work either.
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr = variable Then
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
Next i
Else
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
End If
End If
Next
End If
Next
End With
End Sub
I changed my code but it is still not work properly, I have a result:
try this
Sub test()
Dim Cl As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
With Sheets("Sheet1")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
If Cl.Value <> "" Then
Dic.Add Cl.Row & "|" & Replace(LCase(Cl.Value), ";", "||") & "|", Cl.Offset(, 1).Text
End If
Next Cl
End With
With Sheets("Sheet2")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each Key In Dic
If Key Like "*|" & LCase(Cl.Value) & "|*" And Cl.Value <> "" Then
Cl.Offset(, 1).Value = Dic(Key)
Exit For
End If
Next Key
Next Cl
End With
End Sub
Output Result
Sub YourVLookup()
Dim rng As Variant, rng2 As Variant
Dim lastRow As Long, i As Long, j As Long, k As Long
Dim aCell As Variant, bCell As Variant
Dim myAr() As String, variable As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow)
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow)
For i = LBound(rng2, 1) To UBound(rng2, 1)
If Len(Trim(rng2(i, 1))) <> 0 Then
variable = rng2(i, 1)
For j = LBound(rng, 1) To UBound(rng, 1)
If Len(Trim(rng(j, 1))) <> 0 Then
If InStr(1, rng(j, 1), ";") > 0 Then
myAr = Split(rng(j, 1))
For k = LBound(myAr) To UBound(myAr)
If myAr(k) = variable Then
rng2(i, 2) = myAr(k)
End If
Next k
ElseIf rng(j, 1) = rng2(i, 1) Then
rng2(i, 2) = rng(j, 2)
End If
End if
Next j
End If
Next i
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow) = rng
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow) = rng2
End Sub
You were pasting something that you don't have copied already, you forgot to close a With, and you can't use bCell(,2), so
Try this :
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr() As String
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
End With
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr(i) <> variable Then
Else
'You were pasting nothing with that
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
Next i
Else
'Same here
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
End If
Next aCell
End If
Next bCell
End With
End Sub