So I have a macro which takes an invoice I have copied into a worksheet, and copies the premium amount and pastes it onto the summary tab in the cell that corresponds with the same social security number on both sheets. Here is the macro:
Sub Eyemed2()
Dim rw, LastRow, LastRRow As Long
Dim rng As Range, Found As Range, SheetEnd3 As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Eyemed 2")
Set ws2 = Sheets("Raw")
LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
Set rng = ws2.Range("A2:B" & LastRow)
LastRRow = ws1.Cells(Rows.Count, "R").End(xlUp).Row
For rw = 14 To LastRRow 'Begin in row 14 of Eyemed 2
If Not ws1.Range("R" & rw) Is Nothing Then
is blank
Set Found = rng.Find(What:=ws1.Range("A" & rw).Value,
LookIn:=xlValues)
If Not Found Is Nothing Then
ws2.Range("N" & Found.Row) = ws1.Cells(rw, "J").Value
Else
Set SheetEnd3 = rng.Find(What:=ws1.Range("A" & rw).Value,
LookIn:=xlValues)
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
ws1.Range("A" & rw).Copy ws2.Range("B" & LastRow)
ws2.Range("N" & SheetEnd3.Row) = ws1.Cells(rw, "J").Value
End If
End If
Next rw
End Sub
So it looks at column R in 'Eyemed 2' and if it isn't blank, then copy over the cell in column N into the summary tab, column J. It finds the appropriate row to paste in the summary tab by searching for the social security number in column A of 'Eyemed 2' in column A:B in the summary tab.
My issue is that in 'Eyemed 2', some of the social security numbers are listed more than once with two different amounts. So I need to edit the macro to sum all amounts with the same social security number and then search and paste into one entry in the summary tab as opposed to now where it just copies and pastes one amount.
Thank you very much
If there are multiple matches then this just leaves you with the last value found:
ws2.Range("N" & Found.Row) = ws1.Cells(rw, "J").Value
...but this will add each value to any previous value
With ws2.Range("N" & Found.Row)
.Value = .Value + ws1.Cells(rw, "J").Value
End with
Related
Ok... I am struggling with something that is probably simple... I have a formula in cell B2 and I want to fill to the last cell that contains data or formatting (same as when you press CTRL+END) or in other words "the bottom right corner" of my data. How do I do this? There is data in column "A" and in row "1"... So it needs to fill to the last row and last column containing data...
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Range("B2").AutoFill Destination:=Range(Range("B2"), Cells(2, lastCol)), Type:=xlFillDefault
Range("B2:B" & lastCol).AutoFill Destination:=Range("B2"), Cells(lastRow, lastCol)), Type:=xlFillDefault
The below code helps you determine, and reference, your "box range." The code is making 3 assumptions that you may need to amend for if incorrect:
1) The "top left corner" of your box range is B2
2) Values in Col B span to the bottom of your range. If you expect blanks in Col B, change this to a different column.
3) Values in row 2 span to the end of your used columns. If you expect blanks in row 2, change this to a different row.
Sub RangeBox()
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets(1)
Dim LRow As Long
Dim LCol As Long
LRow = WS.Range("B" & WS.Rows.Count).End(xlUp).Row
LCol = WS.Cells(2, Columns.Count).End(xlToLeft).Column
MsgBox "Last Row: " & LRow & vbNewLine & "Last Column: " & LCol
'How to refer to the box range starting from A1
Dim Start As Range
Set Start = WS.Range("B2")
WS.Range(Start, WS.Cells(LRow, LCol)).Select
End Sub
To fill this range with a formula:
WS.Range(Start, WS.Cells(LRow, LCol)).Formula = "=Sum(1,2)"
Inside the quotes, type the equation in as you would in excel and used locked references if needed ($). The above example would fill your range with the value 3.
I am very new to VBA. Just started reading it up 2 days ago. I am wondering how could I write a VB codes assigned to a button to read through the whole column and search for similar numbers.
After that identifying similar numbers, it would need to move on to another column to check if the character in the column are same too.
If both of the logic = true . How can i change the cell of the value of another column?
Sample data
For the current example. The code should know that the first column had matching numbers. After that it will check for the name which is "a" in the example. After that it will automatically change the point to 1 and 0. If there are 3 same ones it will be 1,0,0 for the point
You may try recording whatever you want to do with record macros first, then filter out the codes that are not necessary. If you do not know how to record it using macros, click on the link below. You can learn from the recorded macros and slowly improvise your codes in the future from the experience you may gain.
Here's [a link] (http://www.dummies.com/software/microsoft-office/excel/how-to-record-a-macro-in-excel-2016/)
As per image attached in image I am assuming numbers are in Column A, column to check characters is Column J and result needs to be displayed in Column O then try following code.
Sub Demo()
Dim dict1 As Object
Dim ws As Worksheet
Dim cel As Range, fCell As Range
Dim lastRow As Long, temp As Long
Dim c1
Set dict1 = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
c1 = .Range("A2:A" & lastRow)
For i = UBound(c1, 1) To 1 Step -1 'enter unique values with corresponding values in dict1
dict1(c1(i, 1)) = .Range("J" & i + 1) '+1 for Row 2
Next i
Set fCell = .Range("A2")
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A
temp = WorksheetFunction.CountIf(.Range(fCell, cel.Address), cel) 'get count
If temp > 1 Then
If cel.Offset(0, 9) = dict1(cel.Value) Then
cel.Offset(0, 14).Value = 0
Else
cel.Offset(0, 14).Value = 1
End If
Else
cel.Offset(0, 14).Value = 1
End If
Next cel
End With
End Sub
EDIT
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row 'last row with data in Column A
.Range("O2").Formula = "=IF(MOD(SUMPRODUCT(($A$2:$A2=A2)*($J$2:$J2=J2)),3)=1,1,0)" 'enter formula in Cell O2
.Range("O2").AutoFill Destination:=.Range("O2:O" & lastRow) 'drag formula down
.Range("O2:O" & lastRow).Value = .Range("O2:O" & lastRow).Value 'keep only values
End With
Application.ScreenUpdating = True
End Sub
The title of the question might be a little confusing but essentially what I am trying to do is write a value to column A if Column B is not empty. This must be repeated for C through Q. The code I have now produces the desired result IF there is value in the B column. However, if there is no value for B then my replacement text will fill in all sorts of blank cells outside of the target range of A1:A. Here is the code I have:
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).Formula = "=If(B1<>"""",""NEW VALUE"","""")"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
I am fairly new to VBA so please forgive any vagueness in my post.
Instead of inserting formulas and getting their values afterwards, you can do the same logic by using pure VBA:
Sub Update_Column_Based_On_Column_Value_1()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If .Cells(i, 2) <> "" Then
.Cells(i, 1) = "NEW VALUE"
End If
Next i
End With
End Sub
This formula will only work if A1 is the first blank.
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).Formula = "=If(B1<>"""",""NEW VALUE"","""")"
.SpecialCells(xlCellTypeBlanks) may be a discontiguous range of areas that may or may not start in row 1. You need to convert it to an xlR1C1 style formula in order to have it correctly identify the first blank row.
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW VALUE"", TEXT(,))"
TEXT(,) is the same as "" and you do not have to double-up the quotes within a quoted string; similarly, any positive number representing the length of a value in column B is the same as <>"".
I need a way to replace values in my primary worksheet (main) with values from my secondary worksheet (update).
my main worksheet has these column names: EmpName, EmpID, EmpSupervisor, Emp Director.
and my secondary worksheet: EmpName, EmpID, New Sup, NewDir, Status.
if an entry in the 2nd worksheet has STATUS listed as "mismatch", it will automatically pass the "new sup" and/or "new dir" data with the corresponding EmpID and overwrite "empsupervisor" and/or "empdirector" in the primary sheet.
something like this, i just can't put it in a correct syntax that vba can understand.
for each STATUS = Mismatch in worksheet2
update worksheet1.column("Empsupervisor") with worksheet2.column("New Sup").value
where worksheet1.column("EmpID") = worksheet2.column("EmpID")
next
This method loops through all rows, checks for mismatch, finds the employee ID row, then moves the new supervisor and new director into the first sheet:
Sub TestIt()
Dim LastRow As Long, CurRow As Long, DestRow As Long, DestLast As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Name of main worksheet")
Set ws2 = Sheets("Name of secondary worksheet")
LastRow = ws2.Range("B" & Rows.Count).End(xlUp).Row
DestLast = ws1.Range("B" & Rows.Count).End(xlUp).Row
For CurRow = 2 To LastRow 'Assumes first row has headers
If ws2.Range("E" & CurRow) = "mismatch" Then 'Assumes mismatch is in column E
If Not ws1.Range("B2:B" & DestLast).Find(ws2.Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
DestRow = ws1.Range("B2:B" & DestLast).Find(ws2.Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole).Row
End If
ws1.Range("C" & DestRow).Value = ws2.Range("C" & CurRow).Value 'assumes supervisor is in column C in both sheets
ws1.Range("D" & DestRow).Value = ws2.Range("D" & CurRow).Value 'assumes director is in column D in both sheets
End If
Next CurRow
End Sub
Explanation of LastRow:
Range("B" & Rows.Count) goes to the last row on the sheet which is Row 1,048,576 in Excel '07, '10, and '13. So imagine Range("B1048576"). Then it performs End(xlUp) which is "Equivalent to pressing END+UP ARROW" according to MSDN. This will go to the first cell in column B that is non-blank above B1048576. The last command .Row returns that row number of the cell.
Explanation of DestRow:
We are using a Range.Find() method to identify if the employeeID exists in the first worksheet and on what row it exists. Range.Find() returns a range which is why I use Range.Find().Row because when found, we want to know the row we are going to. However, if Find() doesn't find anything, it returns Nothing and Nothing.Row would error. Therefore I do a quick If Not Find() Nothing to make sure the value is found.
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With