I have an Excel sheet with names in column A and an amount in column B for sheet 1.
I have a another sheet that is sheet2 with names in A just like in sheet 1 and column B is blank.
How can I check sheet 1 A name to check with sheet2 A name, if they match then take amount next to that name on sheet1 and copy the amount into the cell next to the matching name on sheet2 next to the name? The names on sheet1 change daily.
I have tried this and get nothing.
Sub Macro1()
'
' Macro1 Macro
'
Dim RowIndex As Integer
Sheets("Sheet1").Select
RowIndex = Cells.Row
While DoOne(RowIndex)
RowIndex = RowIndex + 3
Wend
End Sub
Function DoOne(RowIndex As Integer) As Boolean
Dim Key
Dim Target
Dim Success
Success = False
If Not IsEmpty(Cells(RowIndex, 1).Value) Then
Key = Cells(RowIndex, 1).Value
Sheets("sheet2").Select
Set Target = Columns(2).Find(Key, LookIn:=xlValues)
If Not Target Is Nothing Then
Rows(Target.Row).Select
Selection.Copy
Sheets("Sheet1").Select
Rows(RowIndex + 1).Select
Selection.Insert Shift:=xlDown
Rows(RowIndex + 2).Select
Application.CutCopyMode = False
Success = True
End If
End If
DoOne = Success
End Function
Sheet 1:
A B
A One Preservation $16.00
A&D Recovery, Inc. $8,108.46
A&S Field Services, Inc. $4,941.56
A&T Jax Inc $1,842.48
Sheet 2:
A B - blank cell
A One Preservation - Calvin & Renee
A&D Recovery, Inc. - Drew & Adam
A&S Field Services, Inc. - Aaron
A&T Jax Inc - Tyson
This code uses an Index/Match solution to copy the matched B values from sheet1 from sheet2. The code will work with variable sheet names
blank cells are ignored
Non-matches on the second sheet are flagged as "no match".
The code removes the formulae from column B on the second sheet by updating with values only
Update: if you second sheet names are the same as sheet1, but have a " -some text" to the right, then use this updated part of the code
With rng1.Offset(0, 1)
.FormulaR1C1 = "=IF(RC[-1]<>"""",IF(NOT(ISERROR(MATCH(LEFT(RC[-1],FIND("" -"",RC[-1])-1),'" & ws1.Name & "'!C[-1],0))),INDEX('" & ws1.Name & "'!C,MATCH(LEFT(RC[-1],FIND("" -"",RC[-1])-1),'" & ws1.Name & "'!C[-1],0)),""no match""),"""")"
.Value = .Value
End With
original
Sub QuickUpdate()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
Set rng1 = ws2.Range(ws2.[a1], ws2.Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 1)
.FormulaR1C1 = "=IF(RC[-1]<>"""",IF(NOT(ISNA(MATCH(RC[-1],'" & ws1.Name & "'!C[-1],0))),INDEX('" & ws1.Name & "'!C,MATCH(RC[-1],'" & ws1.Name & "'!C[-1],0)),""no match""),"""")"
.Value = .Value
End With
End Sub
Why not use the VLOOKUP function?
Sheet1 has your names in column A, and values in column B.
Sheet2 has your lookup names in column A, and in column B, you put:
=VLOOKUP(A1,Sheet1!$A$1:$B$n,2,FALSE)
Where 'n' is the number of rows in your Sheet1 table.
The only issue with this is it will put an #N/A if it can't find the name in Sheet1. There's likely a way to put in an alternate entry using a conditional.
Related
I have the macro below runs (no errors) but no results are provided. I have an excel book where duplicates are sometimes found in column "E". Those identified as duplicates should be copied to sheet 2. I know my workbook has duplicates in column E, their just not being copied over.
Sub FilterAndCopy()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Application.ScreenUpdating = False
With wstSource
Set rngMyData = .Range("a1:R" & .Range("a" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
.Value = .Value
If Evaluate("=COUNTBLANK(" & .Address & ")") > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
Because of the cell notation you are using R1C1, your formula
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
refers only to column A
If you want to change your formula to apply on column E, that would be
.FormulaR1C1 = "=if(countif(c5,RC5)>1,"""",1)"
I don't know if your dupplicates are on a single column basis or if should concatenate all your column to see if the entire row is a dupplicate. It might be more simple to apply a sql query connection on this. Pivot tables may also help. If you stick to vba, add additional line for each dupplicate formula and process it in the block of code that copy blank formula to the secondary sheet.
I'm attempting to move the adjacent cell range D:E down one row based upon the value in column B.
For example, if a row in column B contains the word "Deposit", then the macro should shift the adjacent cell range D:E down one row.
My issue is that the macro is inserting two rows instead of just one.
I've included some screenshots of my data.
Here is my code:
Sub InsertCellsDown()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim cba As Range
LastRow = Cells.Find("Deposit", SearchOrder:=xlRows, SearchDirection:=xlPrevious).Row
For Each cba In Range("B2:B" & LastRow)
If cba <> cba.Offset(1, 0) Then
Range("D" & cba.Row & ":E" & cba.Row).Insert Shift:=xlDown
End If
Next cba
Application.ScreenUpdating = True
End Sub
Starting data:
Goal:
Problem:
I need your help with VBA!
I want to write a code that will sum the "sales" column in different 7 sheets. The problem is that the column has a different location in each sheet and a dinamic rows' count. The sum should be in the last row + 1.
I am not very good at macros, but I guess I should start with checking i to 7 sheets. Then I should sum a range based on the header ("Sales"). I am lost about how to write all of this..
Try the next code, please:
Sub SumSales()
Dim sh As Worksheet, rngS As Range, lastRow As Long
For Each sh In ActiveWorkbook.Sheets 'iterate through all sheets
'find the cell having "Sales" text/value
Set rngS = sh.Range(sh.Cells(1, 1), sh.Cells(1, _
sh.Cells(1, Columns.count).End(xlToLeft).Column)).Find("Sales")
'if the cell has been found (the cell range is NOT Nothing...)
If Not rngS Is Nothing Then
'Determine the last row of the found cell column:
lastRow = sh.Cells(Rows.count, rngS.Column).End(xlUp).row
'Write the Sum formula in the last empty cell:
rngS.Offset(lastRow).formula = "=Sum(" & rngS.Offset(1).address & _
":" & sh.Cells(lastRow, rngS.Column).address & ")"
sh.Range("A" & lastRow + 1).Value = "Sum of sales is:"
Else
'if any cell has been found, it returns in Immediate Window (Being in VBE, Ctrl + G) the sheet names not having "Sales" header:
Debug.Print "No ""Sales"" column in sheet """ & sh.name & """."
End If
Next
End Sub
I am trying to AutoFilter (in column A of SHEET 1) the Active Cell in SHEET 2. Then I have an IF Statement that counts the number of Visible Rows, and if it is more than 1 (to exclude the header) then I would like to insert a new row into SHEET 3 and cut and paste the values of the Auto filtered Row in SHEET 1 into the new row in SHEET 3.
Then I clear the Auto Filter in SHEET 1, and insert a new row into SHEET 1 and cut and paste the values of the Active Cell's Row from SHEET 2 into the new row in SHEET 1.
IF there are no results from the Auto Filter in SHEET 1, then the ELSE STATEMENT clears the Auto Filter in SHEET 1, inserts a new row into SHEET 1 and cut and pastes the values of the Active Cell's Row from SHEET 2 into the new row in SHEET 1.
Currently, I can't seem to get my code to work if the Auto Filter results in SHEET 2 are in any rows > Row 2. Here is my current code, I have commented to help with navigation:
Sub Autofilter_Macro()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
Dim rng As Range
Dim AC As Integer
AC = ActiveCell.Row
sh1.AutoFilterMode = False 'Clears any AutoFilters from Sheet1
sh1.Range("A:A").Autofilter Field:=1, Criteria1:=ActiveCell.Value 'AutoFilters SHEET 1 column "A" based off the ActiveCell Row in SHEET 2
Set rng = sh1.UsedRange.SpecialCells(xlCellTypeVisible) 'Sets rng to visible cells
' If (rng.Rows.Count > 1) Then 'Counts the # of visible rows
If rng.Areas.Count = 2 Then
sh3.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row (with the same format as the one below it) into row 2 of SHEET 3
' sh3.Range("A2:CK2").Value = rng.Offset(rowOffSet:=1).Value 'Sets the new empty row's values in SHEET 3 = the values of the Autofiltered row in SHEET
rng.Rows(2).Value.Cut sh3.Range("A2")
sh1.ShowallData 'Clears any Autofilters from SHEET 1
sh1.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row (with the same format as the one below it) into row 2 of SHEET 1
sh1.Range("A2:CK2").Value = sh2.Range(Cells(AC, 1), Cells(AC, 89)).Value 'Sets the new empty row's values in SHEET 1 = the values of the ActiveCell row in SHEET 2
MsgBox "Replaced Main Database" 'MsgBox indicating what has executed
Else
sh1.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row (with the same format as the one below it) into row 2 of SHEET 1
sh1.Range("A2:CK2").Value = sh2.Range(Cells(AC, 1), Cells(AC, 89)).Value 'Sets the new empty row's values in SHEET 1 = the values of the ActiveCell row in SHEET 2
MsgBox "New Entry into Main Database"
End If
sh1.ShowallData 'Clears any Auotfilters from SHEET 1
End Sub
Thank you to CDP1802 for his answer below, here is the final code for anyone using this as reference:
Sub Autofilter_Macro()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet 'Declares variables as worksheets
Dim rng As Range 'Declares variable as a range to store values
Set sh1 = Sheet1 'Assigns a worksheet to the declared worksheet variable (sh1 = "Main Database" Worksheet = Machine Inv #)
Set sh2 = Sheet2 'Assigns a worksheet to the declared worksheet variable (sh 2 = "Changes" Worksheet)
Set sh3 = Sheet3 'Assigns a worksheet to the declared worksheet variable (sh 3 = "Historical Parameters" Worksheet)
Dim rowAC As Long, rowCut As Long 'Declares variable and assigns it as a Long data type
rowAC = ActiveCell.Row 'Sets the Long variable as the Active Cell Row
If Len(ActiveCell.Value) = 0 Then 'Tests if the Active Cell in column A (Key) of the "Changes" Worksheet is blank or not
MsgBox "Blank Key in:" & ActiveCell.Address, vbCritical 'If the Active Cell is blank, then this MsgBox notifies you that it's blank
Exit Sub 'Ends the entire Macro if the Active Cell is Blank
End If 'Doesn't initiate the MsgBox and continues the Macro if the Key in Column A is not blank
sh1.AutoFilterMode = False 'Clears any Autofilters (if any) in Sheet 1
sh1.Range("A:A").Autofilter Field:=1, Criteria1:=ActiveCell.Value 'Autofilters Sheet 1 for the Active Cell (Key) from Sheet 2 ("Changes" Worksheet)
Set rng = sh1.UsedRange.SpecialCells(xlCellTypeVisible) 'Sets the range varaible to visible cells in Sheet 1 (Main Database)
If rng.Areas(1).Rows.Count > 1 Then 'Tests if the Active Cell (Key) from Sheet 2 (Changes) is in Row 2 of Sheet 1
rowCut = rng.Areas(1).Rows(2).Row 'If the key is present, stores the values of Row 2 in Sheet 1 as a variable called "rowCut"
ElseIf rng.Areas.Count > 1 Then 'Tests if the Active Cell (Key) from Sheet 2 (Changes) is present in any Row of Sheet 1 (Excluding Row 1 "The Header", and Row 2)
rowCut = rng.Areas(2).Rows(1).Row 'If the key is present, stores the values of the row that has the Active Cell "Key" in Sheet 1 as a variable called "rowCut"
End If 'If the Key is not present in Sheet 1, the variable "rowCut" will not hold any values and be equal to zero
sh1.ShowallData 'Clears Autofilters in Sheet 1
If rowCut > 0 Then 'If the variable "rowCut" was succesful in holding a row's values from Sheet 1, then the following executes:
sh3.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row into Sheet 3 Row 2 w/ same format as the row below it
sh1.Rows(rowCut).Copy sh3.Range("A2") 'Copies the Active (Cell) Row from Sheet 1 (Main Database) & pastes it into the empty row 2 in Sheet 3 (Historical Parameters)
sh1.Rows(rowCut).Delete 'Deletes the Active (Cell) Row from Sheet 1
End If 'If the variable "rowCut" was unsuccesful in holding a row's values from Sheet 1, then nothing will happen to Sheet 3 (Historical Parameters)
sh1.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row into Sheet 1 Row 2 w/ same format as the row below it
sh2.Range("A" & rowAC & ":CK" & rowAC).Copy sh1.Range("A2") 'Copies the Active (Cell) Row from Sheet 2 (Changes) & pastes it into the empty row 2 in Sheet 1
sh2.Range("A" & rowAC & ":CK" & rowAC).Delete 'Deletes the Active (Cell) Row from Sheet 2
End Sub
The problem is that the visible range is non-contiguous like "$A$1:$D$1,$A$6:$D$6" so the rng.Offset(rowOffSet:=1) will always give $A$2:$D$2. Range has a areas property. Using rng.areas.count you can do something like
If rng.Areas.Count = 1 Then
sh3.Range("A2:CK2").Value = rng.Offset(rowOffSet:=1).value
Else
sh3.Range("A2:CK2").Value = rng.Areas(2).value
End If
This is the test program I used
Sub test()
Dim rng As Range
With ThisWorkbook.Sheets("Sheet1")
Set rng = .UsedRange.SpecialCells(xlCellTypeVisible)
End With
If rng.Areas.Count > 1 Then
Debug.Print "Rng", rng.Address
Debug.Print "Rng Offset", rng.Offset(rowOffSet:=1).Address
Debug.Print "rng Area(2)", rng.Areas(2).Address
Else
Debug.Print "rng", rng.Address
Debug.Print "rng offset", rng.Offset(rowOffSet:=1).Address
End If
End Sub
Edit - Incorporating that principle into your code I get
Sub Autofilter_Macro()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rng As Range
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
Dim rowAC As Long, rowCut As Long
rowAC = ActiveCell.Row
If Len(ActiveCell.Value) = 0 Then
MsgBox "Blank value in " & ActiveCell.Address, vbCritical
Exit Sub
End If
MsgBox "Value = " & ActiveCell.Value
'AutoFilters SHEET 1 column "A" based off the ActiveCell Row in SHEET 2
sh1.AutoFilterMode = False
sh1.Range("A:A").AutoFilter Field:=1, Criteria1:=ActiveCell.Value
'Sets rng to visible cells
Set rng = sh1.UsedRange.SpecialCells(xlCellTypeVisible)
If rng.Areas(1).Rows.Count > 1 Then
rowCut = rng.Areas(1).Rows(2).Row
ElseIf rng.Areas.Count > 1 Then
rowCut = rng.Areas(2).Rows(1).Row
End If
sh1.ShowAllData 'Clears any Auotfilt
If rowCut > 0 Then
'Inserts an empty row into Sheet 3 Row 2
'with the same format as the one below it
'copy/paste/delete filter row to sheet3
sh3.Rows("2:2").Insert Shift:=xlDown, _
CopyOrigin:=xlFormatFromRightOrBelow
sh1.Rows(rowCut).EntireRow.Copy
sh3.Activate
sh3.Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh1.Activate
'sh1.Range("A" & rowCut).Interior.Color = vbRed
sh1.Rows(rowCut).Delete
End If
'insert row in sheet1 and copy from sheet2
sh1.Rows("2:2").Insert Shift:=xlDown, _
CopyOrigin:=xlFormatFromRightOrBelow
sh2.Range("A" & rowAC & ":CK" & rowAC).Copy
sh1.Range("A2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
I am trying to copy certain cells if the word "FLAG" is a cell in that same row.
For example, I have data in excel like the following:
So if the word Flag is in any of the cells I want to copy the Description, Identifier and Final Maturity columns (Columns A-C) as well as the corresponding date column. So for the first row (AA) under Jan/Feb there is the word Flag. I would want to copy over columns A-E to another worksheet or table.
I would like to use a VBA but I am not sure how
The following code will do what you expect, each time it finds the word FLAG, the first 3 cells will be copied as well as the value for the given month will be copied to a new row, and if a second flag is found that will be copied to the next available row:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim wsResult As Worksheet: Set wsResult = Sheets("Sheet2")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To LastRow 'loop through rows
For x = 15 To 23 'loop through columns
If ws.Cells(i, x) = "FLAG" Then 'if FLAG found in column
NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1 'get the next empty row of your wsResult sheet
ws.Range("A" & i & ":C" & i).Copy 'copy first three cells in given row
wsResult.Range("A" & NextFreeRow).PasteSpecial xlPasteAll 'paste into your Result sheet
ws.Cells(i, x - 11).Copy 'copy the value for which there was a flag
wsResult.Cells(NextFreeRow, 4).PasteSpecial xlPasteAll 'paste in the fourth cell in the sheet wsResult
End If
Next x
Next i
End Sub