My process consists:
Going through the cell values in Column A of sheet 1
Checking to see if the cell values from sheet 1 match with any of the values in Column C of sheet 2
If there is a match, copy the entire row in which there is a match from Sheet 2 to Sheet 3.
I posted my code below but somehow can't get it to work.
Sub Test1()
Dim Name As String
Dim lastrow As Long
Dim Cell As Variant
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Name = Cells(i, 1)
If Name <> "" Then
For Each Cell In Sheets("Sheet2").Range("C2:C4000")
If Cell.Value = Name Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Sheet3").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet2").Select
End If
Next
End If
Next
End Sub
No need to loop through every cell in Sheet2!C:C.
Sub Test1()
Dim i As Long, c as variant
With Worksheets("Sheet1")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
c = Application.Match(.Cells(i, "A").Value2, Worksheets("Sheet2").Columns(3), 0)
If Not IsError(c) Then
Worksheets("Sheet2").Rows(c).Copy _
Destination:=Worksheets("Sheet3").Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next i
End With
End Sub
You need to get the .Value of the cell.
Name = CStr(Cell(i, 1).Value)
Also, there is a built in function to determine if a cell is empty.
If Not IsEmpty(Cell(i, 1).Value) Then
Also, I would suggest setting a reference to the worksheet instead of just saying Cells()
Dim ws As Worksheet
Set ws = Excel.Application.ThisWorkbook.Worksheets("wb name here")
ws.Cells(i, 1).Value
Hope this helps!
Where your errors were coming from was it was getting confused what sheet was selected. So you needed to be more explicit, as below.
Sub Test1()
Dim Name As String
Dim lastrow As Long
Dim Cell As Variant
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Name = Sheets("Sheet1").Cells(i, 1)
If Name <> "" Then
For Each Cell In Sheets("Sheet2").Range("C2:C4000")
If Cell.Value = Name Then
matchRow = Cell.Row
Sheets("Sheet2").Select
ActiveSheet.Rows(matchRow).Select
Selection.Copy
Sheets("Sheet3").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet2").Select
End If
Next
End If
Next
End Sub
Related
Looking to loop through column B and if the word 'Match" is present copy the value in column A and paste to E7 sheet1. tried this:
Private Sub Consolidate_Matches()
Dim Match As String
Dim FinalRow As Integer
Dim i As Integer
Match = Sheets("Sheet1").Range("P1").Value
FinalRow = Sheets("Sheet1").Range("B10000").End(xlUp).Row
For i = 2 To FinalRow
If Cells(i, 2).Value = "Match" Then
Range(Cells(i, -1)).Copy
Range("e7").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next
End Sub
Try:
Sub test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To Lastrow
If .Range("B" & i).Value = "Match" Then
.Range("E7").Value = .Range("A" & i).Value
End If
Next i
End With
End Sub
i'm trying to make some changes in excel file using VBA, the file contains many sheets
the code should make changes for 1st sheet then go to the next and next,
but after makes the changes in 1st sheet and go to 2nd it shows:
Error no 1004 "Object error".
Here the code:
Sub AddRefNo()
'This code adds Reference Number to All BOQ sheets based on Worksheet Name
'select the first sheet
Worksheets(4).Select
' Work in One Sheet
Do While ActiveSheet.Index < Worksheets.Count
'add new Column
'the error happens here
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Ref. No"
Range("A2").Select
'Find Sheet Name
MySheet = ActiveSheet.Name
'creat numbering system
Dim Noe As String
Noe = 0
' Find the last row
Dim LastRow As Integer
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("E2").Select
'repeat steps to the last row
Do While ActiveCell.Row < LastRow
'checking if the cell is not blank
Do While ActiveCell.Value <> ""
ActiveCell.Offset(0, -4).Select
Noe = Noe + 1
ActiveCell.Value = MySheet & " - " & Noe
ActiveCell.Offset(0, 4).Select
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select
Loop
Noe = 0
Range("A1").Select
ActiveSheet.Next.Select
Loop
Worksheets(1).Select
End Sub
Here is a way to reliable loop through your worksheet index numbers:
Sub AddRefNo()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim x As Long
For x = 4 To wb.Worksheets.Count - 1
Set ws = wb.Worksheets(x)
'Your code to work with ws as a parent
Next x
End Sub
This should do the trick if you want to loop from sheet 4:
Option Explicit
Sub AddRefNo()
'Declare a worksheet variable
Dim ws As Worksheet
'Loop every sheet in the workbook
For Each ws In ThisWorkbook.Worksheets
If ws.Index < 4 Or ws.Index = ThisWorkbook.Worksheets.Count Then GoTo nextWorksheet
'Reference always the sheet
With ws
'Calculate last row
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
'Insert a column
.Range("A:A").Insert
.Range("A1") = "Ref. No"
'Put the name sheet + reference starting from 1
With .Range("A2:A" & LastRow)
.FormulaR1C1 = "=" & Chr(34) & ws.Name & Chr(34) & "&ROW(RC)-1"
.Value = .Value
End With
End With
nextWorksheet:
Next ws
End Sub
I'm writing a code to look for a specific keyword ("Team") and when found I want to paste the team name in a specific column ("D") for all rows above. If the keyword is not found I want to copy the entire row. This all pasted into a new sheet.
What I have:
x-------------x------------x
x-------------x------------x
Team A----x------------x
x-------------x-------------x
x-------------x-------------x
Team B----x-------------x
What I want:
x----x----x----A
x----x----x----A
x----x----x----B
x----x----x----B
Here's what I have so far:
Sub fun()
Dim j as Integer
Dim lastrow as Integer
Dim team as String
Dim sh As Worksheet
sh = Sheets("Sheet 1")
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlup).Row
Range("A" & lastrow).Select
for j = 1 to lastrow
If Instr(Cells(j,1).Value, "Team") Then
Cells(j,1).Value = Replace(Cells(j,1).Value, "Team ", "")
Cells(j,1).Value = team
Else
Range(Cells(j,1), Cells(j,3). Select
Selection.Copy
Windows("sheet.xlsm").Activate
ActiveSheet.Cells(1,1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
End If
next j
End Sub
I'm able to meet the second condition and paste entire rows but I'm unsure how to copy the team names and post them in column D in the new sheet.
Something like this:
Sub fun()
Dim j As Long, destRow As Long
Dim team As String, v, rngTeam As Range
Dim sh As Worksheet, shDest As Worksheet
Set sh = Sheets("Sheet1")
Set shDest = Sheets("Sheet2") 'for example
destRow = shDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To sh.Cells(Rows.Count, 1).End(xlUp).Row
v = sh.Cells(j, 1).Value
If InStr(v, "Team") > 0 Then
If Not rngTeam Is Nothing Then rngTeam.Value = Replace(v, "Team ", "") '<< set for already-copied rows
Set rngTeam = Nothing 'reset the range
Else
shDest.Cells(destRow, 1).Resize(1, 3).Value = sh.Cells(j, 1).Resize(1, 3).Value
'add to the range to populate next time we hit a "Team"
If rngTeam Is Nothing Then
Set rngTeam = shDest.Cells(destRow, 4)
Else
Set rngTeam = Application.Union(shDest.Cells(destRow, 4), rngTeam)
End If
destRow = destRow + 1
End If
Next j
End Sub
I am still new to coding so i apologise if i dont understand everything.
I need to check each cell of D3:D5000 if they start with GUF. Then remove the GUF from it. Else dont do anything.
This is what ive been trying to use but im getting an error Do ohne Loop:
Sub RemoveGUFfromcellsstartingwithGUF()
Range("D3").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveCell = "end"
Range("B1").Select
Do Until ActiveCell = "end"
If ActiveCell = "GUF*" Then
ActiveCell.Value = Mid(Cell, 4, 999999)
End If
ActiveCell.Offset(1, 0).Select
End Sub
Thanks for any help/suggestions
Firstly, when you are looping through cells, it's best to use For each cell in cells, no need to change selection then.
Firstly, set a range in which you want it to run.
Sub RemoveGUFfromcellsstartingwithGUF()
dim first_cell as Range
dim last_cell as Range
dim rng as Range
set first_cell = ActiveSheet.Range("D1") 'first cell of your range
set last_cell = ActiveSheet.Range("D5000") 'last cell of your range
set rng = Range(first_cell, last_cell) 'range from first_cell to last_cell
For Each cell in rng.cells 'looping through cells of the range
'What you do here will be done to every cell.
if left(cell.value, 3) = "GUF" then cell.value = Mid(cell.value,4)
Next cell
End Sub
I hope this helps.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Find last row in Col D
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Loop through cell in Col D
For i = 3 To lRow
If .Range("D" & i).Value Like "GUF*" Then
.Range("D" & i).Value = Mid(.Range("D" & i).Value, 4)
End If
Next i
End With
End Sub
I'm new on VBA and also on this site. I found and adapted this code to my needs, but it copy only the first row from column A(sheet "Vectori") in the blank cells of "TABEL" sheet(column A), and i want to copy all values from column A(sheet "Vectori"), not only one.
Sub test()
Dim myvalue As String
Dim lastrow As Long
lastrow = Rows(Rows.count).End(xlUp).Row
Worksheets("Vectori").Select
myvalue = Range("A2").value
Worksheets("TABEL").Select
Range("A2").Select
'go to first blank cell
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
'write variable values into this blank row
ActiveCell.value = myvalue
Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 1)).copy
ActiveCell.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End Sub
Just increase the Range to suit your needs.
Replace:
Range("A2")
With:
Range("A2:Z100")
Just select the range that covers your entire data.
I solved it :)
Sub test()
Dim thisarray As Variant
Dim lastrow As Long
Dim index As Integer
index = 1
lastrow = Cells(Rows.count, 1).End(xlUp).Row
thisarray = Worksheets("Vectori").Range("A2:A" & lastrow).value
While index <= UBound(thisarray)
Worksheets("TABEL").Select
Range("A2").Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.value = thisarray(index, 1)
index = index + 1
Wend
End Sub
Have a nice day!