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
Related
I'm trying to create a macro that will compile specific columns from all worksheets in a workbook into a single new worksheet.
What I have so far creates the new sheet, and returns the correct headers for each column, but copies across all columns from the existing sheets rather than just the columns I have specified.
As can be seen with the column headings, I would like to only copy the values in columns A:I, K:M, R and W:Y from sheets 2 onwards, into columns B:O in the "MASTER" worksheet.
Does anyone have any suggestions as to how I can get this working?
Sub Combine2()
Dim J As Integer, wsNew As Worksheet
Dim rngCopy As Range, rngPaste As Range
Dim Location As String
On Error Resume Next
Set wsNew = Sheets("MASTER")
On Error GoTo 0
'if sheet does not already exist, create it
If wsNew Is Nothing Then
Set wsNew = Worksheets.Add(Before:=Sheets(1)) ' add a sheet in first place
wsNew.Name = "MASTER"
End If
'copy headings and paste to new sheet starting in B1
With Sheets(2)
.Range("A1:I1").Copy wsNew.Range("B1")
.Range("R1").Copy wsNew.Range("K1")
.Range("K1:M1").Copy wsNew.Range("L1")
.Range("W1:Y1").Copy wsNew.Range("O1")
End With
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
'save sheet name/location to string
Location = Sheets(J).Name
'set range to be copied
With Sheets(J).Range("A1").CurrentRegion
Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
'set range to paste to, beginning with column B
Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
'copy range and paste to column *B* of combined sheet
rngCopy.Copy rngPaste
'enter the location name in column A for all copied entries
Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
Next J
With Sheets(1)
Range("A1").Value = "Extract Date"
Range("A1").Font.Bold = True
Columns("A:T").AutoFit
End With
' wsNew.Visible = xlSheetHidden
End Sub
Copy/paste each range in turn in the same way as you have for the headings. (untested)
Dim ar(4), k as Integer
ar(1) = array("A1:I1","B")
ar(2) = array("R1","K")
ar(3) = array("K1:M1","L")
ar(4) = array("W1:Y1","O")
'copy headings and paste to new sheet
With Sheets(2)
For k = 1 to Ubound(ar)
.Range(ar(k)(0)).Copy wsNew.Range(ar(k)(1) & "1")
Next
End With
' work through sheets
Dim lr As Long
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
'save sheet name/location to string
Location = Sheets(J).Name
'set range to be copied
With Sheets(J)
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For k = 1 to Ubound(ar)
Set rngCopy = .Range(ar(k)(0)).Offset(1).Resize(lr-1)
'set range to paste to, beginning with column B
Set rngPaste = wsNew.Cells(Rows.Count, ar(k)(1)).End(xlUp).Offset(1, 0)
'copy range and paste to combined sheet
rngCopy.Copy rngPaste
If k = 1 Then
'enter the location name in column A for all copied entries
Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
End If
Next
End With
Next J
Note this block is missing a dot on the ranges to use the With
With Sheets(1)
Range("A1").Value = "Extract Date"
Range("A1").Font.Bold = True
Columns("A:T").AutoFit
End With
I have Three worksheets, and essentially I want to select a cell in Column A of Sheet 2 (As the Active Cell) and check if there are any duplicates in Column A of Sheet 3 (The Range for this Sheet should be from A1 to the last row of Data).
If there are any duplicates, I would like a msgbox to display the number of duplicate values if it's greater than 3.
I have added comments explaining my logic in each step, please feel free to simplify my code as well:
Sub Check_Duplicates()
'Declaring variables
Dim Cell As Variant
Dim Source As Range
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rowAC As Long
Dim Counter As Long
'Assigning a worksheet to the decalred variables
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
'Sets the Long variable as the Active Cell Row in Sheet 2
rowAC = ActiveCell.Row
'Initializing "Source" variable range to last row in Sheet 3
Set Source = sh3.Range("A1", sh3.Range("A1").End(xlDown))
'Looping through each cell in the "Source" variable Range
For Each Cell In Source
'Checking if the "Cell" values in Sheet 3 (in column A to the last row) are equal to the value in the Active Cell in Column A
If Cell.Value = sh2.Range("A" & rowAC).Value Then
'Checking whether the value in "Cell" already exists in the "Source" range
If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
'Counts and stores the number of duplicate values from Sheet 3 "Cells" compared to the Active Cell value in Sheet 1 Column A
Counter = Application.WorksheetFunction.CountIf(sh3.Range("Source,Cell"), sh2.Range("A" & rowAC))
'If there are more than 3 duplicates then display a message box
If Counter > 3 Then
'Msgbox displaying the number of duplicate values in Sheet 3
MsgBox "No. of duplicates is:" & Counter
End If
End If
End If
Next
End Sub
Currently, my code gets to the first IF Statement and simply goes to the End IF, so it doesn't execute past this line and simply goes to Next and then End Sub:
If Cell.Value = sh2.Range("A" & rowAC) .Value Then
Cross Referencing:
https://www.mrexcel.com/board/threads/how-to-check-for-duplicates-and-display-a-count-msgbox.1125070/
Here is the final code I am using for anyone using this question as reference for their issues:
Sub Check_Duplicates()
'Declaring variables
Dim Source As Range
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rowAC As Long, Counter As Long
'Assigning a worksheet to the decalred variables
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
'Sets the Long variable as the Active Cell Row in Sheet 2
rowAC = ActiveCell.Row
'Initializing "Source" variable range to last row in Sheet 3
Set Source = sh3.Range("A1", sh3.Range("A" & Rows.Count).End(xlUp))
'count number of times is in Source range
Counter = Application.WorksheetFunction.CountIf(Source, sh2.Range("A" & rowAC))
'If there are more than 3 duplicates then display a message box
If Counter > 3 Then
'Msgbox displaying the number of duplicate values in Sheet 3
MsgBox "No. of duplicates is: " & Counter
End If
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
I have two worksheets in the same workbook. In Sheet1 Column 1 is of expected stock barcodes, in Sheet2, Column 2 is comprised of the barcodes which I scanned.
I wrote a formula in conditional formatting to check items Column 2 and color them if they are not in Column 1, but I don't want to have to scroll through the entire list to see this.
What I want to do is populate a third (and fourth for quantity) column with only entries that are in Column 2 and not Column 1, and if possible, list the number of times it was found in Column 2.
Example:
Column 1
bc123
bc1234
bc12345
bc123456
bc1234567
Column 2
bc12345
bc123456
bc56789
bc67890
bc67890
Column 3 (Automatically populated with unique entries from column 2)
bc56789 1
bc67890 2
Thank you!
Here, my VBA approach for your problem:
Public Sub findAndCount()
Dim sh1, sh2 As Worksheet
Dim foundCell As Range
Dim startSheet2, resultRow As Integer
'Set sheets
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
'Set the start row of column from Sheet2
startRow = 1
resultRow = 1
'Clear old result from column C & D of Sheet1
sh1.Range("C:D").ClearContents
'Loop all row of column 2 from Sheet2 until blank
Do While sh2.Range("B" & startRow) <> ""
'Find value in column A of Sheet1
Set foundCell = sh1.Range("A:A").Find(sh2.Range("B" & startRow), LookIn:=xlValues)
'If match value is not found
If foundCell Is Nothing Then
'Find result is already exist or not
Set foundCell = sh1.Range("C:C").Find(sh2.Range("B" & startRow), LookIn:=xlValues)
'If result is not exist, add new result. (Here, I show result in Sheet1, you can change it.)
If foundCell Is Nothing Then
'Set barcode
sh1.Range("C" & resultRow) = sh2.Range("B" & startRow)
'Set count
sh1.Range("D" & resultRow) = 1
'Increase result row
resultRow = resultRow + 1
'If already exist
Else
'Increase count
foundCell.Offset(0, 1) = foundCell.Offset(0, 1).Value + 1
End If
End If
'Increase row
startRow = startRow + 1
Loop
End Sub
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.