I have a list of names in a Sheet3,
Column A:6-33 has the names of some clients
Column B:6-33 empty
Column C:6-33 empty
I also have Sheet4:
column A 5000 client names
column C & F have important data of that client which I need to copy to Column B & C in Sheet3.
So when Sheet3.Cell Ax == Sheet4.Cell Ax
Sheet3.B & C needs to copy the data of Sheet4.C & F
Somehow I'm not being able to get the loop right.
right now I have tunnel vision and I can't seem to fix this problem.
Dim clientrange As Range
Dim searchrange As Range
Dim i As Long
Set clientrange = ActiveWorkbook.Sheets(3).Range("A6") 'you may have to use sheets("sheet3")
With ActiveWorkbook.Sheets(4) 'you may have to use sheets("sheet4")
While clientrange.Text <> ""
'search for clients in sheet4
For i = 1 To 5000
If .Range("A" & i) = clientrange.Text Then
'copy the values
clientrange.Offset(0, 1) = .Range("C" & i)
clientrange.Offset(0, 2) = .Range("F" & i)
Exit For
End If
Next i
'go one down
Set clientrange = clientrange.Offset(1, 0)
Wend
End With
One possible solution is VLOOKUP function:
Sheet 3
Column B formula (import the formula in Cell B6 and drag down):
=VLOOKUP(A6,Sheet4!$A$1:$F$5000,3,0)
Column C formula (import the formula in Cell C6 and drag down):
=VLOOKUP(A6,Sheet4!$A$1:$F$5000,6,0)
VBA Code:
Option Explicit
Sub tes()
Dim ws3 As Worksheet, ws4 As Worksheet
Dim i As Long
Dim rngSearch As Range, rngFound As Range
Dim arr As Variant
Dim strValueC As String, strValueF As String
With ThisWorkbook
Set ws3 = .Worksheets("Sheet3")
Set ws4 = .Worksheets("Sheet4")
End With
With ws3
arr = .Range("A6:A33")
.Range("B6:C33").Clear
End With
Set rngSearch = ws4.Range("A1:A5000")
For i = LBound(arr) To UBound(arr)
Set rngFound = rngSearch.Find(What:=arr(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
With ws4
strValueC = .Range("C" & rngFound.Row).Value
strValueF = .Range("F" & rngFound.Row).Value
End With
With ws3
.Range("B" & i + 5).Value = strValueC
.Range("C" & i + 5).Value = strValueF
End With
End If
Next i
End Sub
Related
Using VBA, I am trying to search for each value in column A of sheet 1, and match it with column A of sheet 2. If a value is found in sheet 2, update column B to "Yes"
Sheet 1
Sheet 2
So far I have:
Sub UpdateStatus()
Dim list() As Variant
Dim item As Integer
'Assign range to a variable
list = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Loop Through Rows
For item = 1 To UBound(list)
'this is where I am stuck
Next item
End Sub
Sheet 2 should look like this afterwards:
Why loop if you can use Excel's engine?
Solution using Excel formulas
Sub Update_Status()
Dim Formula As String
Dim searchRng As Range
Dim valueRng As Range
Dim statusRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set valueRng = ws1.Range("A2:A" & LastRow("A", ws1)) ' A2, since you have header
Set searchRng = ws2.Range("A1:A" & LastRow("A", ws2))
Set statusRng = valueRng.Offset(0, 1)
' =IF(COUNTIFS(Sheet2!$A$2:$A$4,Sheet1!A2),"Yes","No")
Formula = "=IF(COUNTIFS(" & _
searchRng.Address(True, True) & "," & _
valueRng.Cells(1, 1).Address(False, False) & _
"),""Yes"",""No"")"
statusRng.Formula = Formula
' In case calculation is turned off
Application.Calculate
' If we prefer hardcoded values
statusRng.Copy
statusRng.PasteSpecial xlPasteValues
Application.CutCopyMode = False ' Flush clipboard
End Sub
Private Function LastRow(Col As String, Ws As Worksheet) As Long
LastRow = Ws.Range(Col & Rows.Count).End(xlUp).Row
End Function
This seems to work:
Sub UpdateStatus()
Dim list() As Variant
Dim item As Integer
Dim FoundCell As Range
Dim SearchValue As String
Dim Sheet2 As Worksheet
Set Sheet2 = Worksheets("Sheet2")
'Assign range to a variable
list = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Loop Through Rows
For item = 1 To UBound(list)
SearchValue = list(item, 1)
Set FoundCell = Sheet2.Range("A2:A6").Find(What:=SearchValue)
If Not FoundCell Is Nothing Then
Sheet2.Range("B" & FoundCell.Row).Value = "Yes"
Else
MsgBox (SearchValue & " not found")
End If
Next item
End Sub
I need an excel vba code which copy the data from one sheet and paste it on the other sheet if the given conditions satisfied. There will be two sheets in a workbook (sheet1 and sheet 2). Basically the data in sheet 2 column "C" must be copy to sheet 1 column "C".
The conditions are : -
There will be three columns in SHEET 1&2 A,B,C .
IF SHEET 1 B1 has a data let us take("88").Now,it should search how many of them ("88") are there in sheet2 B:B.
If there are more than one let us take "4" then those "4" sheet2 "C" values are belongs to the sheet 1
"A1". It should create another three rows with "sheet1 A1 & B1" Value then those 4 values must be
paste in "sheet1 "c" beside those four "Sheet A1&B1". iam unable to select those 4 SHEET2 "C" VALUES
If there is one "88" then it can just paste at sheet1"C1".
In this way it should do for every value in sheet 1 B:B.
At least Tell me what code is used to add rows with cell value through vba
How To Find Value & Copy Corresponding Cell
Sub copythedata()
Dim r As Long, ws As Worksheet, wd As Worksheet
Dim se As String
Dim sf As String
Dim fn As Integer
Dim y As Integer
Dim lrow As Long
Set ws = Worksheets("sheet2")
Set wd = Worksheets("sheet1")
y = 123
x = wd.Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "Last Row: " & x
If x > y Then
wd.Range(wd.Cells(y, 1), wd.Cells(x, 1)).EntireRow.Delete Shift:=xlUp
End If
For r = wd.Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
fn = Application.WorksheetFunction.countif(ws.Range("B:B"), wd.Range("B" & r).Value)
If fn = 1 Then
wd.Range("C" & r).Value = ws.Range("C" & r).Value
ElseIf fn > 1 Then
se = wd.Range(wd.Cells(A, r), wd.Cells(B, r)).EntireRow.Copy
wd.Range("A123").Rows(fn - 1).Insert Shift:=xlShiftDown
Else
wd.Range("C" & r).Value = "NA"
End If
Next r
End Sub
See Find and
FindNext
When using FindNext see the Remarks section for how to stop search after the 'wraparound' to the start, otherwise you get into an endless loop.
Option Explicit
Sub copythedata()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim iLastRow1 As Integer, iLastRow2 As Long
Dim iRow As Integer, iNewRow As Long, iFirstFound As Long
Dim rngFound As Range, rngSearch As Range
Dim cell As Range, count As Integer
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("sheet2")
' sheet 2 range to search
iLastRow2 = ws2.Range("B" & Rows.count).End(xlUp).Row
Set rngSearch = ws2.Range("B1:B" & iLastRow2)
'Application.ScreenUpdating = False
' sheet1 range to scan
iLastRow1 = ws1.Range("B" & Rows.count).End(xlUp).Row
' add new rows after a blank row to easily identify them
iNewRow = iLastRow1 + 1
For iRow = 1 To iLastRow1
Set cell = ws1.Cells(iRow, 2)
Set rngFound = rngSearch.Find(what:=cell.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If rngFound Is Nothing Then
'Debug.Print "Not found ", cell
cell.Offset(0, 1) = "NA"
Else
iFirstFound = rngFound.Row
Do
'Debug.Print cell, rngFound.Row
If rngFound.Row = iFirstFound Then
cell.Offset(0, 1) = rngFound.Offset(0, 1).Value
Else
iNewRow = iNewRow + 1
ws1.Cells(iNewRow, 1) = cell.Offset(, -1)
ws1.Cells(iNewRow, 2) = cell.Offset(, 0)
ws1.Cells(iNewRow, 3) = rngFound.Offset(0, 1).Value
End If
Set rngFound = rngSearch.FindNext(rngFound)
Loop Until rngFound.Row = iFirstFound
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
So I have an excel sheet where I want to loop through Sheet1 and find data pairs similar to Sheet2. So, I have for example A1:B1 and I need to find a row on Sheet2 that has exactly the same values next to each other (but it could be A33:B33 or anywhere) and copy the row over to Sheet1 (in column C or anything)
I am also trying to make it a dynamic loop so it checks for A1:B1 pair against Sheet2 then A2:B2 and so on until the last row.
Now the code I have only checks if A1:B1 on Sheet1 matches A1:B1 on Sheet2 (but not anywhere on the sheet). Also, I cannot make it so that it dynamically checks against every row on Sheet1 (I tried to make it with the x = x + 1 but it doesn't work)
Here is my code:
Sub matchme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
r = lastrow = sh1.Range("A" & Rows.Count).End(xlUp).Row
For x = 1 To r
If sh1.Range("A" & x) = sh2.Range("A" & x) And sh1.Range("B" & x) = sh1.Range("A" & x) & sh2.Range("B" & x) Then
sh1.Range("A" & x).EntireRow.Copy Destination:=sh2.Range("C" & x)
x = x + 1
Next x
End Sub
Please help, I have been struggling with this for days now and I need to hand in a report by the end of today, and I just cannot find anything helpful on the internet. I really appreciate any advice
If You want to use loops, try that:
Sub matchme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim x As Long
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim lastRow2 As Long
Dim lastCol2 As Long
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastrow = sh1.Range("A" & Rows.Count).End(xlUp).Row
With sh2
lastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
lastCol2 = .Cells(1, Columns.Count).End(xlUp).Column
End With
For x = 1 To lastrow
For i = 1 To lastRow2
For j = 1 To lastCol2
If sh1.Cells(x, 1) = sh2.Cells(i, j) Then
If sh1.Cells(x, 2) = sh2.Cells(i, j + 1) Then
MsgBox "Found match!"
End If
End If
Next j
Next i
Next x
End Sub
I haven't tested this.
I've assumed you are searching for sheet1 A values in sheet2 column A only.
When a match is found, the column C value on sheet2 is copied to column C on sheet1.
Sub x()
Dim rFind As Range, s As String, r As Range
With Sheet1
For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFind = Sheet2.Columns(1).Find(What:=r.Value, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
If rFind.Offset(, 1).Value = r.Offset(, 1).Value Then
r.Offset(, 2).Value = rFind.Offset(, 2).Value
End If
Set rFind = Sheet2.Columns(1).FindNext(rFind)
Loop While rFind.Address <> s
End If
Next r
End With
End Sub
To get the pairs of Sheet1 and look for them in Sheet2:
I've used this code:
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
Dim rng As Range
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim SearchThis As String
Set wk1 = ThisWorkbook.Worksheets("Sheet1")
Set wk2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = wk1.Range("A" & wk1.Rows.Count).End(xlUp).Row
'<--------------------------------->
'For more type of SPECIAL CELLS, and choose exactly the type you need
'please read https://learn.microsoft.com/en-us/office/vba/api/excel.range.specialcells
For i = 1 To LastRow Step 1
SearchThis = UCase(wk1.Range("A" & i).Value & wk1.Range("B" & i).Value)
For Each rng In wk2.Cells.SpecialCells(xlCellTypeConstants, 23)
If UCase(rng.Value & rng.Offset(0, 1).Value) = SearchThis Then
'code to copy where you want
Debug.Print rng.Row
End If
Next rng
Next i
Set wk1 = Nothing
Set wk2 = Nothing
Application.ScreenUpdating = True
The output of this code is:
Those are the row numbers where the pairs are. You just need to add a code to copy the entire row.
Hope this helps
Try below code (comments in code):
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastRow = sh1.Range("A" & Rows.Count).End(xlUp).Row
iLastRow = sh2.Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To lastRow
For i = 1 To iLastRow
If sh1.Cells(j, 1) = sh2.Cells(i, 1) And sh1.Cells(j, 2) = sh2.Cells(i, 2) Then
sh1.Cells(i, 3) = "Write some information"
End If
'you don't need to increment loop variable "Next" does it for you
'also i is better suited for iterator name :)
Next
Next
I need help. I need to search my worksheet and find a specific word ("substances"), then copy the value in the cell 2 columns over into a different sheet.
For example, in Sheet1, if "substances" was found in A4, then copy value from C4 and paste into Sheet2 under last filled row. I need to continue doing this for the entire worksheet. "Substances" does not occur sequentially, but always in column A (i.e. the first occurrence may be A4, the ext one might be in A16).
Here's what I have so far:
Dim Cell, cRange As Range
Set cRange = Sheets("Sheet1").Range("A1:A75")
For Each Cell In cRange
FindCounter = 0
If Cell.Value = "Substances" Then
FindCounter = FindCounter + 1
Sheets("Sheet1").Cell.Value(0, 2).Copy
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True
Try this. Find is more efficient than looping (for reasons I have never fully understood).
Sub x()
Dim rFind As Range, s As String
With Sheets("Sheet1").Range("A1:A75")
Set rFind = .Find(What:="Substances", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = rFind.Offset(, 2).Value
Set rFind = .FindNext(rFind)
Loop While rFind.Address <> s
End If
End With
End Sub
Alternative using for loop:
Sub Copy()
Dim i As Long
Dim lRow1 As Long, lRow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
'set worksheets
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
'set last row to search for substances
lRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
'start for loop
For i = 1 To lRow1
If ws1.Range("A" & i).Value = "Substances" Then
'assuming you want to paste into column A on sheet 2
'adjust as you need to
lRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row + 1
ws2.Range("A" & lRow2).Value = ws1.Range("A" & i).Offset(0, 2).Value
End If
Next
'clear objects
Set ws1 = Nothing
Set ws2 = Nothing
End Sub
I have the following problem:
600 columns, with 25 rows of data.
I need to copy the data from columns 2 to 600 and place them at the end of the content in column1.
Any information in how I can do this will be greatly appreciated.
Here's the code I currently use:
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Dim r As Long
Set rng1 = Range("A1", Range("A1048576").End(xlUp))
Set rng2 = Range("B1", Range("B1048576").End(xlUp))
r = rng1.Rows.Count + 1
For Each cl In rng2
Cells(r, 1).Value = cl.Value
r = r + 1
Next
End Sub
The problem is it only copies B column and not the other columns (eg. C, D, E, etc.)
Here's what you need I guess:
Tested:
Sub Test()
Dim ws as WorkSheet
Dim C1_lrow, C2_lrow, lcolumn, i as Long
Dim rng as Range
Set ws = Thisworkbook.Sheets("Sheet1") 'change this to what you have
With ws
C2_lrow = .Range("B" & .Rows.Count).End(xlup).Row
lcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range("B1:B" & C2_lrow)
End With
For i = 0 to lcolumn - 1
C1_lrow = ws.Range("A" & Rows.Count).End(xlup).Row
rng.Offset(0, i).copy ws.Range("A" & C1_lrow + 1)
Next i
End Sub
Try if it works for you.
I would not solve this in Excel only.
Save the file as a csv-file
Open the file with a editor-like (e.g. Notepad++)
Replace ";" with " " or ", "
Save the file
Open the file with Excel
Now you have only 1 column left.
If you need this to be done automatic, you'll need a script.