I want to use each value/string in a certain column (A1, A2, A3...) in worksheet 1 to search a certain range in worksheet 2 for that value/string alone and (!) with additional endings.
Example: Use in worksheet 1 A1 = K-1234 and search in a defined range in worksheet 2 for the string K-1234 and combinations of K-1234 with /x, /y, /z. Whenever you find such a combination copy the whole row from worksheet 2 into a new worksheet 3.
Using column A in worksheet 1:
worksheet 1
A
A1 = K-1234
A2 = Y-1234
A3 = RP-78
…
A1000 = Z/34-1
Searching in worksheet 2 in the range B1:E3 for A1, A1/x, A1/y and A1/z:
worksheet 2
A B C D E
GHJ A1/x 456 G5G F1-1
FF- A1 23-A TTR BV1
8/a A1/z bnR 34-1 bn/1
That's how worksheet 3 should look like after using A1 from worksheet 1 to search in worksheet 2:
worksheet 3
A B C D E
FF- A1 23-A TTR BV1
GHJ A1/x 456 G5G F1-1
8/a A1/z bnR 34-1 bn/1
or with A1 written out:
worksheet 3
A B C D E
FF- K-1234 23-A TTR BV1
GHJ K-1234/x 456 G5G F1-1
8/a K-1234/z bnR 34-1 bn/1
(A1/y doesn't exist)
Continue with A2, A2/x, A2/y and A2/z and so on till the end of the column (for example A1000).
Hope I could explain the problem sufficiently. I would be very thankful for any suggestion.
You could try:
Option Explicit
Sub CopyYes()
Dim i As Long, LastRow1 As Long, LastRow3 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rngToSearch As Range, rngFound As Range
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1")
Set ws2 = .Worksheets("Sheet2")
Set ws3 = .Worksheets("Sheet3")
End With
Set rngToSearch = ws2.Range("B1:E3")
With ws1
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
Set rngFound = rngToSearch.Find(.Range("A" & i).Value & "*", LookIn:=xlValues)
If Not rngFound Is Nothing Then
LastRow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
If LastRow3 = 1 And ws3.Range("A1").Value = "" Then
LastRow3 = 1
Else
LastRow3 = LastRow3 + 1
End If
ws2.Range("B" & rngFound.Row & ":E" & rngFound.Row).Copy
ws3.Range("A" & LastRow3).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
End Sub
Related
My question is of two parts:
Part 1:
I have two worksheets. In one worksheet named "Equipment details" I have a set of values in column A, rows 13 to 1000. I want to copy each of these values, namely A13, A14, A15 and so forth in to another worksheet named "Worksheet(2)" starting at cell A2. However, the trick is A13 from the first worksheet needs to be copied into A2 of the second worksheet, A14 to A8, A15 to A14 and so on in increments of 6 each time.
This part was sorted out earlier.
Part 2:
The new values copied over from "Equipment details" to "Worksheet(2)" now need to copy down their values to the next 6 rows and so on. For example, the Value in Cell A2 in "Worksheet(2)" needs to be copied down to rows A3 to A8. Then the next value in A9 that was copied over from "Equipment details" in Part 1 needs to be copied down from A10 to A15 and so on. This is my code and it works well in copying from Row A3 toA8 but then it does not jump to row A10 and instead keeps overwriting the values in rows A3 to A8.
Sub CopyDataInBetweenCells()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim destws As Worksheet
Set destws = wb.Worksheets("Worksheet (2)")
Dim RowNo2 As Long
Dim RowNo3 As Long
For RowNo2 = 1 To 2000
For RowNo3 = 1 To 6
destws.Cells(RowNo2 * 7 - 5, 1).Copy Destination:=destws.Cells(RowNo3 * 1 + 2, 1)
Next RowNo3
Next RowNo2
End Sub
Calculate the destination range:
Sub CopyData2()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim srcws As Worksheet
Set srcws = wb.Worksheets("Equipment details")
Dim destws As Worksheet
Set destws = wb.Worksheets("Worksheet (2)")
Dim RowNo As Long
For RowNo = 0 To 987
srcws.Range("A" & RowNo + 13).Copy Destination:=destws.Range("A" & RowNo * 7 + 2 & ":A" & RowNo * 7 + 8)
Next RowNo
End Sub
Use Resize
Sub CopyDataInBetweenCells()
Dim wb As Workbook, destws As Worksheet
Set destws = wb.Worksheets("Worksheet (2)")
Dim RowNo As Long, n As Long
With destws
For n = 1 To 2000
RowNo = 2 + (n - 1) * 7
.Cells(RowNo + 1, 1).Resize(6) = .Cells(RowNo, 1)
Next
End With
End Sub
I need to create a column with the difference between a column and a cell (A3) in a loop.
In the picture I would for example like to know impact 1 with the H3 to a H.. = scenario(F3 to F...) - A3 and impact 2= Scenario2(G3...G)-A3 for x years (B3) for example.
I started with an if loop but I struggled to loop the whole column.
Sub Lab1()
Dim i As Integer
If i <= Range("B3").Value Then
Range("H3").Value = Range("F3").Value - Range("A3").Value
Range("J3").Value = Range("G3").Value - Range("A3").Value
End If
i = 2020 + Range("B5").Value
End Sub
I'm a little iffy on where column P from your code comes into play with your screenshot, but this should roughly do what you're looking for I think. Let us know if you run into any issues!
Sub loop1()
'define variables to work with
Dim ws As Worksheet
Dim interCol As Long, scen1Col As Long, impact1Col As Long
Dim firstRow As Long, lastRow As Long
Dim rng As Range
Dim intervention As Long, scenario As Long
Dim i As Long
'define current worksheet
Set ws = ActiveSheet
'define column numbers
interCol = 1 'A
scen1Col = 6 'F
impact1Col = 8 'H
'define start row
firstRow = 3
'end row is the last non-blank cell in Scenario 1 column
lastRow = ws.Cells(ws.Rows.Count, scen1Col).End(xlUp).Row
'loop from first row to last row
For i = firstRow To lastRow
'define cell to update
Set rng = ws.Cells(i, impact1Col)
'intervention doesn't change from row to row
intervention = ws.Cells(firstRow, interCol)
'scenario varies from row to row
scenario = ws.Cells(i, scen1Col)
'update target cell with calculation
rng = scenario - intervention
Next i
End Sub
For a project I am working on, I am attempting to copy a row from an excel spreadsheet, only if the correct criteria are met.
For example,
I need to copy a row that has the following items in them:
Fruit, Apple, True, Cell<4
I've tried using something like
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Set SrchRng = ActiveSheet.Range("A4:T60", ActiveSheet.Range("A60:T60").End(xlUp))
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Copy
Sheets("Results").Paste
Next strSearch
End Sub
But the problem with this is that it only searches for a single criteria: Apple. I need the script to scan the whole row for all filters to be correct, then copy the row.
The script I used also only copies the row once, and does not seem to copy all rows that include Apple.
I am assuming that your data is consistent i.e. you are looking for Fruit in one column, Apple in another column and likewise for TRUE and <4.
Here in the code I am looking for Fruit in Column A, Apple in Column B, TRUE in Column C and <4 in Column D. You can change column numbers as required.
I've named the sheet where data is as Data and the sheet to paste copied rows as Results
Sub CopyRow()
Dim LastRowCurr As Long, LastRowResult As Long
Dim LastColumn As Long
Dim i As Long
Dim currWS As Worksheet, resultWS As Worksheet
Dim MyRange As Range
Set currWS = ThisWorkbook.Sheets("Data") '---> sheet where data is
Set resultWS = ThisWorkbook.Sheets("Results") '---> sheet to paste copied rows
lastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row
LastRowResult = resultWS.Cells(Rows.Count, "A").End(xlUp).Row
With currWS
For i = 4 To lastRow
'change column numbers in the below line as required
If .Cells(i, 1).Value = "Fruit" And .Cells(i, 2).Value = "Apple" And .Cells(i, 3).Value = True And .Cells(i, 4).Value < 4 Then
.Rows(i).Copy Destination:=resultWS.Range("A" & LastRowResult)
LastRowResult = LastRowResult + 1
End If
Next i
End With
End Sub
I guess this is what you want.
you have to add another loop for the .find function. On your Code it only looks once for Apples. What you have to do is, you have to add another loop and repeat the .find function until you this .find function gives your the first match again . Try something like this:
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Dim wsResults As Worksheet
Dim firstAddress
Set SrchRng = ActiveSheet.Range("A1:T60", ActiveSheet.Range("A60:T60").End(xlUp))
Set wsResults = ThisWorkbook.Worksheets("Results")
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy wsResults.UsedRange.Cells(wsResults.UsedRange.Rows.Count + 1, 1)
Set c = SrchRng.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next strSearch
End Sub
If cell C2 value is in the range P2:P25 then paste the value in the matching row of Column T into the same row of Column N.
View here for image.
One way, written as a standalone example and assumes that data is on Sheet1 and transfers the first match. Note that there is no error checking/handling in this example.
Sub xferNum()
Dim ws As Worksheet
Dim srow As Long, erow As Long, scol As Long, srchcol As Long
Dim rsltcol As Long, lucol As Long
Dim fndNo As Range, c As Range, lookrng As Range
Set ws = Sheets("Sheet1")
srow = 2
scol = 3
srchcol = 16
lucol = 20
rsltcol = 14
With ws
erow = .Cells(.Rows.Count, scol).End(xlUp).Row
Set lookrng = .Range(.Cells(srow, scol), .Cells(erow, scol))
For Each c In lookrng
Set fndNo = Columns(srchcol).Find(what:=c.Value)
If Not fndNo Is Nothing Then
.Cells(c.Row, rsltcol).Value = fndNo.Offset(0, lucol - fndNo.Column).Value
End If
Next c
End With
End Sub
In cell N2 put this formula: =IF(C2=P2, T2, "")
Then highlight cell N2 down to N25 and fill down. (CTRL + D).
I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.