I wrote a code to find a value (say B) that is closest to the input (say A and A is a number) using Xlookup worksheetfunction. I also need the cell address of the returned value B so that i can make a range for further processing.
It works fine with the xlookup function but I have error while trying to use the find function to find the value
Private Sub Worksheet_Activate()
Dim rng1, result_rng1 As Range
Dim ws As Worksheet
Dim nowsheet As Worksheet
Dim start_rng, end_rng As Range
'Set start_rng = Nothing
'''active sheet is the sheet containing input value A in
lat_row = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (lat_row)
For i = 2 To lat_row
''Name of the sheet in xlookup shall look for value A
Set ws = Sheets(ActiveSheet.Cells(i, 2) & "_Orcaflex_Depth")
''' last row of ws
last_row = ws.Cells(Rows.Count, 2).End(xlUp).Row
'MsgBox (last_row)
''Range in ws in which A shall be searched
Set rng1 = ws.Range(ws.Cells(2, 2), ws.Cells(last_row, 2))
'''' Set result_rng1 = ws.Range(ws.Cells(2, 3), ws.Cells(last_row, 3))
''return the value in the cell as d1
d1 = Application.WorksheetFunction.XLookup(ActiveSheet.Cells(i, 4).Value, rng1, rng1, , -1)
' MsgBox (d1)
ActiveSheet.Cells(i, 16) = d1
Next i
'''this loop shall find the cell address of the cell containing the value that was discovered using the previous loop
For i = 2 To lat_row
''Name of the sheet in xlookup shall look for value A
Set ws = Sheets(ActiveSheet.Cells(i, 2) & "_Orcaflex_Depth")
Set nowsheet = Sheets("Result_Offset")
''' last row of ws
last_row = ws.Cells(Rows.Count, 2).End(xlUp).Row
'MsgBox (last_row)
Set results_rng1 = ws.Range(ws.Cells(2, 2), ws.Cells(last_row, 2))
Set start_rng = results_rng1.Find(what:=nowsheet.Cells(i, 16).Value, LookIn:=xlValues)
MsgBox (Cells(start_rng).Address)
Next i
End Sub
Related
I have been struggling with this code. I want to loop through Column E beginning with E5, on the Sheet titled "pivot of proposal" (which is a pivot table); and every time it finds a cell with the value of "check" I want it to copy/paste value of cells A & B of the corresponding row to the sheet titled Check Payments in E & F, moving down a row each time but beginning on row 4. I tried to piece together other bits of code but it is not doing what I need it to.
Sub Loop_Check_Payments()
Dim c As Range
Dim IRow As Long, lastrow As Long, krow as long
Dim copyrow As Integer
Dim rSource As Range
Dim DataOrigin As Worksheet, DataDest As Worksheet, DataDestACH As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set DataOrigin = ThisWorkbook.Sheets("Pivot of proposal")
'~~> Output sheet
Set DataDest = ThisWorkbook.Sheets("CHECK PAYMENTS")
Set DataDestACH = ThisWorkbook.Sheets("ACH_WIRE PAYMENTS CASH POOLER")
Application.ScreenUpdating = False
'~~> Set you input range
Set rSource = Range("Payment_Method")
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "Check" Then
DataDest.Cells(4 + IRow, 5) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(4 + IRow, 6) = DataOrigin.Cells(c.Row, 2)
IRow = IRow + 1
Else
DataDestACH.Cells(4 + kRow, 7) = DataOrigin.Cells(c.Row, 1)
DataDestACH.Cells(4 + kRow, 8) = DataOrigin.Cells(c.Row, 2)
kRow = kRow + 1
End If
Next c
Whoa:
MsgBox Err.Description
End Sub
Instead of trying to Copy/paste - you can do something like this (as PeterT alluded to in comments)
this will put values from columns A&B (ordinal 1 & 2) of the SOURCE to the same row/column in the destination:
If c.Value = "Check" Then
DataDest.Cells(c.Row, 1) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(c.Row, 2) = DataOrigin.Cells(c.Row, 2)
End If
This is what my end result should look like. If there is not the four digits to move over to the second column then fill with 4 zeros.
How can I split zip code in a column into 2 columns and fill empty cells in column 2 if first column has only 5 digits?
Here is what I have been working with
Dim ws As Worksheet
Dim cell As Range
Set ws = Worksheets("sheet1")
For Each cell In ws.Range("K2:K500").Cells
cell.Offset(0, 1).Value = Left(cell.Value, 5)
Next cell
Dim cel As Range, rngC As Range, rngB As Range
Dim lastRowA As Long, lastRowB As Long
With ws
lastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row 'last row of column A
lastRowL = .Cells(.Rows.Count, "L").End(xlUp).Row 'last row of column B
For Each cel In .Range("K2:K" & lastRowL) 'loop through column L
'check if cell in column A exists in column B
If WorksheetFunction.CountIf(.Range("K2:K" & lastRowL), cel) = 0 Then
cel.Offset(0, 3).Value = Right(cel.Value, 4)
'.Range("M" & cel.Row) = Right(cell.Value, 4)
Else
.Range("M" & cel.Row) = "0000"
End If
Next
End With
In case you want to bypass VBA and use formulas, you can do this.
Cell B2:
=LEFT(A2,5)
Cell C2:
=IF(LEN(A2)=9,RIGHT(A2,4),"0000")
One of the simplest ways to solve this problem is to supplement the original string with a large number of zeros and take the values of the first and second five characters for two cells:
Sub setZIPandZeros()
Const TEN_ZEROS = "0000000000" ' 10 times
Dim ws As Worksheet
Dim cell As Range
Dim sLongString As String
Set ws = Worksheets("Sheet1")
For Each cell In ws.Range("K2:K" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).Cells
sLongString = Trim(cell.Text) & TEN_ZEROS
cell.Offset(0, 1).Resize(1, 2).NumberFormat = "#"
cell.Offset(0, 1).Resize(1, 2).Value = Array(Left(sLongString, 5), _
Mid(sLongString, 6, 5))
Next cell
End Sub
Update The modified code is much faster and gives a result that more closely matches the description of the task:
Sub setZipZeros()
Dim ws As Worksheet
Dim rResult As Range
Set ws = Worksheets("Sheet1")
' Addressing R1C1 is used in the formulas - If the original range
' is shifted to another column, you will need to change the letter
' of the column "K" only in this line
Set rResult = ws.Range("K2", ws.Cells(ws.Rows.Count, "K").End(xlUp)).Offset(0, 1)
' If the columns L:M are already in text format, then instead of
' the results we will get the texts of formulas
rResult.Resize(, 2).NumberFormat = "General"
' These two lines do most of the work:
rResult.Formula2R1C1 = "=LEFT(TRIM(RC[-1])&""00000"",5)"
rResult.Offset(0, 1).Formula2R1C1 = "=MID(TRIM(RC[-2])&""000000000"",6,4)"
' We don't know if auto-recalculation mode is on now
' Application.Calculation = xlAutomatic
ActiveSheet.Calculate
Set rResult = rResult.Resize(, 2)
' Set the text format for the cells of the result
' to prevent conversions "00123" to "123"
rResult.NumberFormat = "#"
' Replace formulas with their values
rResult.Value = rResult.Value
End Sub
I have a data set with columns from A to AZ. I want to find if any cell value in Columns A & B is found in Columns AA:AZ and I want a list of those unique not found values from all the compared columns.
What I did first is create 2 new sheets to separate the comparison. 1st sheet (SKUReference) which is copied from column A & B. Second sheet is (SKUNewList) which is copied from AA till AZ. I created a 3rd sheet (NotFoundSKU) to have the desired output which is the Not Found values from the comparison.
The data in the 1st sheet (SKUReference) looks like below :
The data in the 2nd sheet (SKUNewList) looks like below :
The issue I'm facing is : 1- the code isn't finding the Mismatches. 2- It's not storing the unique mismatches correctly. 3- It's not generating those mismatches in the 3rd sheet (NotFoundSKU).
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues)
If c Is Nothing Then
'MsgBox cll.Value2 & " not found in the SKU Reference List."
Sheets("NotFoundSKU").Range("A1") = cll.Value2
End If
Next
End With
End Sub
Try this, which incorporates comments above (to set rngMaster and rngSearch) and will list values not found in a list going down by finding the first empty cell.
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet, c as range, cll as range
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues) 'i would consider adding more parameters here
If c Is Nothing Then
Sheets("NotFoundSKU").Range("A" & Rows.Count).End(xlUp)(2).Value = cll.Value2
End If
Next
End With
End Sub
Is it possible to search for a specific value in a column?
I want to be able to search all of the cells in column "B" and look for the 'word' "pip" in it (without being case sensitive). I've got everything else, just need to know if this is possible or how it can be done.
My Current code looks as follows:
Sub A()
ActiveSheet.Name = "Data"
Dim ws As Worksheet
Set ws = Sheets("Data")
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "pip"
ws.Activate
Row = 2
Dim i As Integer
For i = 1 To 10
If (Cells(i, 2).Value = (HAS pip IN IT) Then 'This is the part that i'm struggling with
Copied = ws.Range(Cells(i, 1), Cells(i, 17)).Value 'If possible, this would cut and paste so it deleted the original
ws1.Activate
ws1.Range(Cells(Row, 1), Cells(Row, 17)).Value = Copied
Row = Row + 1
ws.Activate
End If
Next i
End Sub
Edit: Just to clarify, the value in column B will never just be "pip". It will be a full sentence but if it contains "pip" then i would like the IF function to work.
Find and FindNext work nicely (and quickly!)
'...
Dim copyRange As Range
Dim firstAddress As String
Set copyRange = ws.Range("B1:B1500").Find("pip", , , xlPart)
If Not copyRange Is Nothing Then
firstAddress = copyRange.Address
Do
ws2.Range(Cells(Row, 1), Cells(Row, 17)).Value = Intersect(copyRange.EntireRow, ws.Columns("A:Q")).Value
Row = Row + 1
Set copyRange = Range("B1:B10").FindNext(copyRange)
Loop While copyRange.Address <> firstAddress
End If
'...
I'm new in this forum and in vba language so i'm hoping for some guidance. I have a workbook with different sheets but right now there are only 3 that matter. The first and thrid sheet have data that will be interconnected in the Sheet2.
In Sheet1 and Sheet3 I have Sheet1_Sheet3_Test. And this is Sheet 2 Sheet2_Test which is, in a first fase all empty and I want to automatize it since i was doing this work manually before. In the image is what I need to get. So far I have the following code, which works and fills column C of Sheet2.
But i'm having problems with Column A. I was trying to simply use a formula like:
{=IF(A3=A2;INDEX(Sheet3!$A$3:$A$16;SMALL(IF(ISNUMBER(SEARCH(Sheet1!$B$3;Sheet3!$C$3:$C$16));MATCH(ROW(Sheet3!$C$3:$C$16);ROW(Sheet3!$C$3:$C$16)));ROW(A1)));INDEX(Sheet3!$A3:$A$16;SMALL(IF(ISNUMBER(SEARCH(Sheet1!$B3;Sheet3!$C$3:$C$16));MATCH(ROW(Sheet3!$C$3:$C$16);ROW(Sheet3!$C$3:$C$16)));ROW(A$1))))}
The problem is I get an error when the text in column C changes and right now I'm stuck. I don't know if it will be better to develop another macro or if there is something I can change in the formula.
I'm sorry if it is difficult to understand what I'm asking but it is kind of hard to explain it.
I need to go throught every row in sheet1, so for example: in Sheet 1 I have in row 3, INST - I_1 and ID - AA. The formula searches for AA on sheet3 and returns all values in order and fills column A in sheet 2. Then it will go to row 4 in sheet 1 again and repeat the process once again until there are no more values on Sheet1.
Sub TestSheet2()
Dim Rng As Range
Dim InputRng As Range, OutRng As Range
xTitleId = "Sheet1"
Sheets("Sheet1").Select
Set InputRng = Application.Selection
On Error Resume Next
Set InputRng = Application.InputBox("Select:", xTitleId, InputRng.Address, Type:=8)
xTitleId = "Sheet2"
Sheets("Sheet2").Select
Set OutRng = Application.InputBox("Select:", xTitleId, Type:=8)
Set OutRng = OutRng.Range("A1")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1").Value
xNum = Rng.Range("C1").Value
OutRng.Resize(xNum, 1).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next
End Sub
Based on the images provided, I was able to loop through a couple of arrays and come up with this.
Sub fill_er_up()
Dim a As Long, b As Long, c As Long
Dim arr1 As Variant, arr2() As Variant, arr3 As Variant
With Worksheets("sheet1")
With .Range(.Cells(3, 1), .Cells(Rows.Count, 2).End(xlUp))
.Cells.Sort key1:=.Columns(2), order1:=xlAscending, _
key2:=.Columns(1), order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
arr1 = .Cells.Value2
End With
End With
With Worksheets("sheet3")
With .Range(.Cells(3, 1), .Cells(Rows.Count, 3).End(xlUp))
.Cells.Sort key1:=.Columns(3), order1:=xlAscending, _
key2:=.Columns(1), order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
arr3 = .Cells.Value2
End With
End With
For a = LBound(arr1, 1) To UBound(arr1, 1)
For c = LBound(arr3, 1) To UBound(arr3, 1)
'Do While arr3(c, 3) <> arr1(a, 2): c = c + 1: Loop
If arr3(c, 3) = arr1(a, 2) Then
b = b + 1
ReDim Preserve arr2(1 To 3, 1 To b)
arr2(1, b) = arr3(c, 1)
arr2(2, b) = arr3(c, 3)
arr2(3, b) = arr1(a, 1)
End If
Next c
Next a
With Worksheets("sheet2")
Dim arr4 As Variant
arr4 = my_2D_Transpose(arr4, arr2)
.Cells(3, 1).Resize(UBound(arr4, 1), UBound(arr4, 2)) = arr4
End With
Erase arr1: Erase arr2: Erase arr3: Erase arr4
End Sub
Function my_2D_Transpose(a1 As Variant, a2 As Variant)
Dim a As Long, b As Long
ReDim a1(1 To UBound(a2, 2), 1 To UBound(a2, 1))
For a = LBound(a2, 1) To UBound(a2, 1)
For b = LBound(a2, 2) To UBound(a2, 2)
a1(b, a) = Trim(a2(a, b))
Next b
Next a
my_2D_Transpose = a1
End Function
I added in the id to the second column of the results in sheet2. It seemed a reasonable way to fill blank cells.
I was able to recreate your results table with the code below, filtering the range on Sheet3.
Option Explicit
Sub MergeIDs()
Dim instSh As Worksheet
Dim compfSh As Worksheet
Dim mergeSh As Worksheet
Dim inst As Range
Dim compf As Range
Dim merge As Range
Dim lastInst As Long
Dim lastCompf As Long
Dim allCompf As Long
Dim i As Long, j As Long
Dim mergeRow As Long
'--- initialize ranges
Set instSh = ThisWorkbook.Sheets("Sheet1")
Set compfSh = ThisWorkbook.Sheets("Sheet3")
Set mergeSh = ThisWorkbook.Sheets("Sheet2")
Set inst = instSh.Range("A3")
Set compf = compfSh.Range("A2")
Set merge = mergeSh.Range("A3")
lastInst = instSh.Cells(instSh.Rows.Count, "A").End(xlUp).Row
allCompf = compfSh.Cells(compfSh.Rows.Count, "A").End(xlUp).Row
'--- clear destination
mergeSh.Range("A:C").ClearContents
merge.Cells(0, 1).Value = "COMPF"
merge.Cells(0, 3).Value = "INST"
'--- loop and build...
mergeRow = 1
For i = 1 To (lastInst - inst.Row + 1)
'--- set the compf range to autofilter
compfSh.AutoFilterMode = False
compf.Resize(allCompf - compf.Row, 3).AutoFilter
compf.Resize(allCompf - compf.Row, 3).AutoFilter Field:=3, Criteria1:=inst.Cells(i, 2).Value
'--- merge the filtered values with the inst value
lastCompf = compfSh.Cells(compfSh.Rows.Count, "A").End(xlUp).Row
For j = 1 To (lastCompf - compf.Row)
merge.Cells(mergeRow, 1).Value = compf.Cells(j + 1, 1).Value
merge.Cells(mergeRow, 3).Value = inst.Cells(i, 1).Value
mergeRow = mergeRow + 1
Next j
Next i
End Sub