i would like to compare two columns in two different sheets like column A in sheet 1 start from row 2 till the last row and columns C start from row 2 till the last row. If row in column A is greater than the same row in column C a message box " the value is greater" appear and clear the greater value in column A. Thanks an advance for your support
This should get you started
Sub compare()
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
Dim lastrow As Integer
lastrow = sheet1.Range("A2").End(xlDown).Row
Dim i As Integer
For i = 2 To lastrow
If sheet1.Range("A" & i).Value > sheet2.Range("A" & i).Value Then
MsgBox ("the value is greater")
sheet1.Range("A" & i).Value = ""
End If
Next i
End Sub
Delete Greater Than
Option Explicit
Sub deleteGreaterThan()
Dim wb As Workbook
Dim src As Worksheet
Dim dst As Worksheet
Dim LastRow As Long
Dim i As Long
Set wb = ThisWorkbook
Set dst = wb.Worksheets("Sheet1")
Set src = wb.Worksheets("Sheet2")
LastRow = dst.Cells(dst.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If dst.Cells(i, "A").Value > src.Cells(i, "C").Value Then
MsgBox "The value in cell '" & dst.Cells(i, "A").Address(0, 0) _
& "' is greater."
dst.Cells(i, "A").Value = ""
End If
Next i
End Sub
Related
Would anyone will be able to help me with this script please?
As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.
Sub Insert Row()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i + 1).Value Then ws.Range("A" & i + 1).EntireRow.Insert
Next i
End Sub
Thank you in advanced.
Duplicate Headers
A Quick Fix
Sub InsertHeaders()
Const FIRST_ROW As Long = 1
Const EMPTY_ROWS As Long = 1
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim r As Long
For r = LastRow To FIRST_ROW + 2 Step -1
With ws.Cells(r, "A")
If .Value <> .Offset(-1).Value Then
.EntireRow.Resize(EMPTY_ROWS + 1).Insert
ws.Rows(1).Copy ws.Rows(.Row - 1)
End If
End With
Next r
End Sub
Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.
Example Data :
Expected result after running the sub :
Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim cell As Range
Dim i As Integer: Dim arr: Dim ins As Integer:dim sh as worksheet
Set sh = Sheets("Sheet1") 'change if needed
ins = 3 'change if needed
With sh
.Range("A1").EntireRow.Resize(ins).Insert Shift:=xlDown
Set rgHdr = .Range("A1").EntireRow.Resize(1 + ins)
Set rgData = .Range("K" & 2 + ins, .Range("K" & Rows.Count).End(xlUp))
End With
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next
For i = 1 To arr.Count - 1
rgHdr.Copy
sh.Cells(rgData.Find(arr.Keys()(i), _
after:=rgData.End(xlDown)).Row, 1).Insert Shift:=xlDown
Next
sh.Range("A1").EntireRow.Resize(ins).Delete
End Sub
sh = the sheets where the data is.
ins = skip how many blank rows.
The code use "insert copied cells" method, so it make three blank rows (the value of ins) before the header, then set the first three rows as rgHdr, set the rgData from K2 down to the last row with value.
arr = unique value in column K.
then it loop to each element in arr, get the first row occurence of the found cell which value is the looped element in arr, insert the copied rgHdr to that row.
Then finally it delete those three (ins value is 3) additional blank rows.
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
I am trying to create code (Loop) so that when a task is allocated to a team member (in a cell in column H) the code searches the cell value with the existing sheet names and if there is a match, the sheet then makes the task member sheet active sheet, finds the last available line and adds the allocated tasks to the sheet. The code should run for all filled cells in the column.
However, the code i have currently written bugs out. I am finding it hard to define the worksheetname (Cell value) etc.
Sub TaskAllocation()
Dim cell As Range, Lastrow1 As Double, i As Integer
Dim SubTaskWs As Worksheet, Ws As Worksheet, Lastrow2 As Double
Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")
Set Ws = ActiveWorkbook.Sheets(WsName)
i = o
Lastrow1 = SubTaskWs.Range("H" & Rows.Count).End(xlUp).Row
Lastrow2 = Ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In SubTaskWs.Range("H4:H" & Lastrow1)
For Each Ws In Sheets
If cell.value = Ws.Name Then
Ws.Range("A" + (Lastrow2 + (i))).EntireRow.Insert
Call copyFormattingAbove(Ws, "A" & Lastrow2)
Ws.Range(("A" & Lastrow2) + (i)).value = cell.Offset(, -6)
Ws.Range(("B" & Lastrow2) + (i)).value = cell.Offset(, -5)
i = i + 1
End If
Next Ws
Next cell
End Sub
I did change a bit your code to make it more readable.
Some tips for the future:
Use the Option Explicit on the top of your moduel to fource the declaration of all your variables.
Always try to declare your variables close to where they are used.
Never declare a integervariable, use Long instead. Don't use Double for rows either, Double and Single are for floating numbers.
Here is the code:
Option Explicit
Sub TaskAllocation()
Dim cell As Range
Dim SubTaskWs As Worksheet
Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")
Dim Lastrow1 As Long
Lastrow1 = SubTaskWs.Range("H" & Rows.Count).End(xlUp).Row
Dim ws As Worksheet
Dim cell As Range
Dim Lastrow2 As Long, i As Long
i = 0
Dim Tasks As Object
FillTasks Tasks
For Each cell In SubTaskWs.Range("H4:H" & Lastrow1) 'change this range and loop through the column with the tasks
If Tasks.Exists(cell) Then GoTo AlreadyDone
For Each ws In Sheets
If SubTaskWs.Cells(cell.Row, "H") = ws.Name Then
Lastrow2 = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
copyFormattingAbove ws, "A" & Lastrow2
ws.Range("A" & Lastrow2).Value = SubTaskWs.Cells(cell.Row, 2)
ws.Range("B" & Lastrow2).Value = SubTaskWs.Cells(cell.Row, 3)
End If
Next ws
AlreadyDone:
Next cell
End Sub
Function FillTasks(Tasks As Object)
Set Tasks = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'loop through sheets
If Not ws.Name = "Sub tasks" Then
'code to find the right columnd and loop through the existing tasks
'there is no need for an item on this case, you only need to know if it exists
If Not Tasks.Exists(cell) Then Tasks.Add cell, 1
End If
Next ws
End Function
I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub