I have a sheet which contains a column full of Item IDs called "Werkzeugtabelle Vormontage" and another sheet which contains part of the item IDs listed in sheet 1.
I want to filter Sheet 1 by the Item IDs that are similar to the ones in sheet 2. So basically have the sheet with more IDs chopped to the size of the sheet with less IDs. (Deleting the not similar ones would also be an option but no clue how that might work.)
If CheckSheet("BMV Vormontage") Then
Sheets("Werkzeugtabelle").Select
Sheets("Werkzeugtabelle").Copy After:=Sheets("BMV Vormontage")
ActiveSheet.Name = "Werkzeugtabelle Vormontage"
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Restanschluss Vormontage").Select
xRow = Cells(Rows.Count, 11).End(xlUp).Row
'CountUnique ("K3:K100")
'critCount = CountUnique.Count
For i = 3 To lRow
For a = 10 To xRow
Sheets("Werkzeugtabelle Vormontage").Cells(i, 1).AutoFilter Field:=1, Criteria1:=Sheets("Restanschluss Vormontage").Cells(a, 11).Value
Next a
Next i
End If
The CheckSheet is looking for that sheet to get a starting point in the workbook. "Werkzeugtabelle" is the non filtered vanilla sheet.
Whenever I have more than one similar Item ID between the two sheets, it won't show, because I am only looking for one criteria it seems.
I tried to do a loop.
Alright I guess I have found the solution. At least it does everything it does and doesn't spam me with error. Could you guys double check if this is a good code?
Sub Werkzeugtabelle_splitten()
Dim ws As Worksheet
Dim rng As Variant
Set ws = Sheets("Werkzeugtabelle")
' Splitten Vormontage
If CheckSheet("BMV Vormontage") Then
rng = Sheets("Restanschluss Vormontage").Range("K10:K100").Value
ws.Range("A3").AutoFilter _
Field:=1, _
Criteria1:=Application.Transpose(rng), _
Operator:=xlFilterValues
ws.Copy After:=Sheets("BMV Vormontage")
ActiveSheet.Name = "Werkzeugtabelle Vormontage"
ws.ShowAllData
End If
End Sub
So I have made that the orginial "Werkzeugtabelle" sheet will still exist and it only filters it > copies it to the right spot in the workbook and afterwards resets the filter on the original.
Related
The task at hand is to search in column A to see what values I have (they are in form of letters) and paste for each unique entry, its value once in another column.
Here is a visual explanation:
What I came up with was to create a For loop that iritiates through column A and created a conditional that if it found a certain value then it would insert the value in the range. Here is the code:
For i = 1 to 26
if cells(i,26).value= "A" Then
Range ("C1")= "A"
Elseif cells(i,26).value = "B" then
Range ("C2").value = "B"
ElseIf (i,26).value = "C" then
Range ("C3").value = "C"
EndIf
Next i
end sub
I want to cut this process short as my data set is really big with lots of company names. Any recommendations? I believe there has to be a way of knowing the values without having to look at all the values yourself.
If the goal is to just get a unique list of values found in Column A output to Column C you can use the below macro. This is really just recreating the steps of one method you would manually take to find unique values. Not the most sophisticated solution, but it works
Create a copy of your column with company names (using last available column in sheet)
De-dup the helper column
Copy the de-duped column to destination
Delete the helper column
Assumes the last column on worksheet is not used
Sub Unique()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, lc As Long
'Determine Range Size
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).Column
'Copy Company Names To Helper Column/Remove Duplicates
ws.Range("A2:A" & lr).Copy ws.Cells(1, lc)
ws.Columns(lc).RemoveDuplicates Columns:=1, Header:=xlNo
lr = ws.Cells(ws.Rows.Count, lc).End(xlUp).Row
'Output Unique Values From Helper Column
ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)).Copy
ws.Range("C2").PasteSpecial xlPasteValues
'Delete Helper Column
ws.Columns(lc).Delete
End Sub
Note my comment on post. VBA may not be needed here at all
Here's a slightly different version of using .RemoveDuplicates which also removes blank cells.
You can also do this without VBA. Just copy the desired column to another and use Remove Duplicates under Data tab.
Sub Unique_Values()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
'Getting all the values in column A (except header)
'Copying them into cell C2 and below
ws.Range("A2", Range("A1048576").End(xlUp)).Copy Range("C2")
'setting the header for the column C
ws.Range("C1").Value = "What companies are in Column A?"
'Removing duplicates and blanks from column C
With ws.Range("$C$2", Range("C1048576").End(xlUp))
.Value = .Value
.RemoveDuplicates Columns:=1, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
On Error GoTo 0
End With
End Sub
Although I agree with the coding convention used in the other answer, I think it is over-complicating the problem a little bit that would cause confusion for beginners.
I think both answers so far will give you exactly what you want, and perhaps could be simplified even further?
Sub GetUniqueQuick()
Dim LastRow As Long
Application.ScreenUpdating = False
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet1").Range("A2:A" & LastRow).Copy Sheets("Sheet1").Range("C2")
Sheets("Sheet1").Range("C1:C" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
Using the dynamic features of MS 365 you can simply apply the worksheet function UNIQUE() over a given range, e.g.
= UNIQUE(A2:A100)
or integrate it in a user defined function
Function GetCompanies(rng As Range)
If rng.Columns.Count > 1 Then Exit Function ' allow only one column
GetCompanies = Application.Unique(rng) ' return function result as 2-dim array
End Function
As empty cells result in pseudo-uniques with a 0 output, you could call them in formula with an added cosmetical blank string :
=GetCompanies(A2:A100)&""
I am currently working on deleting rows. I have already made it work in one sheet, but I just want to ask if there is any way to delete rows in several sheets at the same time? I have a unique key which is the student ID that is in Column C of all the sheets that will be affected. So, by clicking on the delete button, all data with this student ID will be deleted.
Using the code below, I can delete a row from the STUDENTS_INFO sheet.
Sub del_stud()
Set ws = ActiveWorkbook.Worksheets("STUDENTS_INFO")
LastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
For r = 10 To LastRow
If CStr(ThisWorkbook.Sheets("HOME").Range("K11").Value) = ws.Cells(r, 3) Then
ws.Rows(r).EntireRow.Delete
MsgBox "Student's data is now deleted!"
Unload Me
End If
Next r
End Sub
The sheets that will be affected are STUDENTS_INFO, G1-Q1, G1-Q2, G1-Q3, G1-Q4, G2-Q1, G2-Q2, G3-Q3, G4-Q4, and so on... I also have sheets that, hopefully, will not be touched. Is this possible?
Based on my research, it uses the For Each ws In ThisWorkbook.Sheets. I tried to use it, but it still deletes the row in STUDENTS_INFO sheet and not on multiple sheets.
Here's the code that I tried.
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Sheets
LastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
For r = 10 To LastRow
If CStr(ThisWorkbook.Sheets("HOME").Range("K11").Value) = ws.Cells(r, 3) Then
ws.Rows(r).EntireRow.Delete
MsgBox "Student's data is now deleted!"
Unload Me
End If
Next r
Next ws
Application.ScreenUpdating = True
I’d agree with #urdearboy’s suggestion of using a filter to delete the rows – plus looping through an array of sheets that you designate. The following code assumes the Student ID is sourced from the cell K11 on the HOME sheet. You can add/remove sheets from the array as you see fit.
Try the following & let me know how you go.
Option Explicit
Sub del_stud()
Dim StudID As String, ws As Worksheet
'Get the filter criteria from cell K11 in the HOME sheet
StudID = ThisWorkbook.Sheets("HOME").Range("K11").Value
'Do the STUDENTS_INFO sheet by itself
With ThisWorkbook.Sheets("STUDENTS_INFO").Cells(8, 3).CurrentRegion
.AutoFilter 1, StudID
.Offset(1).EntireRow.Delete
.AutoFilter
End With
'Do the other generic sheets next - add/remove sheets as required
For Each ws In Sheets(Array("G1-Q1", "G1-Q2"))
With ws.Cells(9, 3).CurrentRegion
.AutoFilter 1, StudID
.Offset(1).EntireRow.Delete
ws.AutoFilterMode = False
End With
Next ws
End Sub
I'm struggling with the updating of a number of sheets that hold master data.
The user can update the register ("TK_Register") with a new item or modify an existing item on the ("EditEX") sheet. Data on the EditEx sheet is stored maintained at C32:P56 and saved on the next empty row of the TK_Register Sheet (Columns A to N)
Using a different code, I can recall all specific rows based on a reference number (stored on EditEX sheet in cells O32:O56 and on the TK_Register sheet in column M).
On running this code,
excel takes all data from EditEx sheet C32:P56
Pastes this data to the next empty row on TK_Register Sheet
Auto filters based on column "N" for "NO" (i.e. don't need to keep this row)
Deletes the rows that where filtered (these are rows that have not been used and contain Default data)
Unfilters the data
This is where I get an issue. This adding all data to the TK_Register sheet includes new Items as well as previous items that have been updated.
As we need to make regular additions, updates and changes, when we need to edit it again we only want to see the most recent line items appear on the EditEx sheet.
The user can then make changes to any of the recalled rows and/or add a new one.
My below code only works where the last row reference number (column M) is duplicated. If more than 1 row is being added, it finds no duplicates.
I know I'm going through this the long way, but any ideas how I can have it search each reference number (column M) being pasted (there will be multiple rows) if found update that row with new data, if not found, add to the next available rows.
Sub SaveUpdatedRec()
Dim rng4 As Range
Set rng4 = Sheets("EditEx").Range("C32:P56")
Sheets("TK_Register").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rng4.Rows.Count, rng4.Columns.Count).Cells.Value = rng4.Cells.Value
Sheets("TK_Register").Range("A1:N1000").AutoFilter field:=14, Criteria1:="NO"
Application.DisplayAlerts = False
Sheets("TK_Register").Range("A2:N1000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error Resume Next
Sheets("TK_Register").ShowAllData
On Error GoTo 0
Sheets("AI_Register").Select
Range("A1").Select
Dim lrow1 As Long
For lrow1 = Worksheets("AI_Register").Cells(Rows.Count, "M").End(xlUp).Row To 2 Step -1
If Cells(lrow1, "M") = Cells(lrow1, "M").Offset(-1, 0) Then
Cells(lrow1, "M").Offset(-1, 0).EntireRow.Delete
End If
Next lrow1
ActiveWorkbook.RefreshAll
Sheets("EditEx").Select
ActiveWindow.SmallScroll Down:=-120
Range("B13").Select
MsgBox ("Record Updates have been Saved")
End Sub
Below is a sample code using .RemoveDupliates which remove duplicates from column 1 of the range given taking in consideration that the column has header.
Option Explicit
Sub test()
Dim LastroW As Long
With ThisWorkbook.Worksheets("Sheet1")
LastroW = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1:A" & LastroW).RemoveDuplicates Columns:=1, Header:=xlYes
End With
End Sub
I have a workbook that consists of 180 worksheets. Each worksheet has the top 9 rows and columns A1:Z1 with information that I do not need.
The rest of the worksheet has data that I do need and want to append into one worksheet. The problem is that each of the worksheet has drop-down choices embedded in them. The choices have already been made and I need to append the sheets with the choices selected.
Been trying to run a VBA script but have been unsuccessful. Any help is greatly appreciated.
Thank you
Current code that I used to remove the top rows for few of the sheets, only removal but not appending. And I have inserted sheet names, but with 180 sheets that will not be possible.
Sub remove_rows()
'
' remove_rows Macro
'
'
`Rows("1:10").Select`
`Selection.EntireRow.Hidden = False`
`Range("D20").Select`
`Rows("1:9").Select`
`Range("A9").Activate`
`Selection.Delete Shift:=xlUp`
`Sheets("BioME-Box- (2)").Select`
`Rows("1:15").Select`
`Selection.EntireRow.Hidden = False`
`Rows("1:9").Select`
`Range("A9").Activate`
`Selection.Delete Shift:=xlUp`
`Sheets("BioME-Box- (3)").Select`
`Rows("1:13").Select`
`Selection.EntireRow.Hidden = False`
Rows("1:9").Select
Range("A9").Activate
Selection.Delete Shift:=xlUp
It sounds like you are talking about Validation lists as your "drop down" lists. If so then they might be getting their options from a another range somewhere else. So if you delete a range that the validation lists are using then all of their options disappear. I don't know if this is your problem. But you can copy a validation list and paste only its value, not the whole list, this way.
Sub Macro1()
Range("D3").Select ' This is the validation list
Selection.Copy
' Change "SomeOtherRangeHere" to any cell you want to
Range("SomeOtherRangeHere").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Try this one. Be sure to change mainWS to the worksheet you are copying to. I used sheet1 but you may be using another. In this sub it copies everything below Row 9 of all sheets and pastes them to the first available row in sheet1.
Sub Macro1()
Dim ws As Worksheet, mainWS As Worksheet
Dim wsLastRow As Long, mainWSlastRow As Long, wsLastCol As Long
Set mainWS = Sheet1 ' Change this to the sheet you are copying everthing to
For Each ws In ThisWorkbook.Worksheets
def = mainWS.Name
abc = ws.Name
If ws.Name <> mainWS.Name Then ' Make sure to not copy from the sheet yuo are copying to
wsLastRow = ws.UsedRange.Rows.Count
wsLastCol = ws.UsedRange.Columns.Count
On Error Resume Next
mainWSlastRow = Sheet1.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
If Err.Number = 91 Then
mainWSlastRow = 1
On Error GoTo 0
End If
ws.Range("A10:" & Chr(wsLastCol + 64) & wsLastRow).Copy Destination:=mainWS.Range("A" & mainWSlastRow + 1)
End If
Next ws
Set mainWS = Nothing
Set ws = Nothing
End Sub
This code is working to copy the filtered data of "Award" column marked "Yes" to another sheet; however, I'm receiving an error of "Type Mismatch." I'm not 100% now that the code is working properly to filter the data and copy correctly. I currently have 23 rows of test data for proper functionality. If I only put one row of data, then it doesn't copy and paste the data correctly. I am left with the copied 1st row of data plus the 2nd empty row of data. Additionally, it is not clearing the contents of the rows after the paste, so I may add new data as the days progress.
Sub CopySheet()
Dim i As Integer
Dim LastRow As Integer
Dim Search As String
Dim Column As Integer
Sheets("MasterData").Activate
Sheets("MasterData").Range("A1").Select
'Sets an Autofilter to sort out only your Yes rows.
Selection.AutoFilter
'Change Field:=5 to the number of the column with your Y/N.
Sheets("MasterData").Range("$A$1:$G$200000").AutoFilter Field:=7, Criteria1:="Yes"
'Finds the last row
LastRow = Sheets("MasterData").Cells(Sheets("MasterData").Rows.Count, "A").End(xlUp).row
i = 1
'Change the 3 to the number of columns you got in Sheet2
Do While i <= 11
Search = Sheets("ActiveJobStatus").Cells(1, i).Value
Sheets("MasterData").Activate
'Update the Range to cover all your Columns in MasterData.
If IsError(Application.Match(Search, Sheets("MasterData").Range("A1:G1"), 0)) Then
'nothing
Else
Column = Application.Match(Search, Sheets("MasterData").Range("A1:G1"), 0)
Sheets("MasterData").Cells(2, Column).Resize(LastRow, 1).Select
Selection.Copy
Sheets("ActiveJobStatus").Activate
Sheets("ActiveJobStatus").Cells(2, i).Select
ActiveSheet.Paste
End If
i = i + 1
Loop
'Clear all Y/N = Y
'Update the Range to cover all your Columns in MasterData.
Sheets("MasterData").Activate
Column = Application.Match("Award", Sheets("MasterData").Range("A1:F1"), 0)
Sheets("MasterData").Cells(2, Column).Resize(LastRow, 1).Select
Selection.ClearContents
End Sub
Sorry to change your code up so much, but it looks like you might be over-complicating how to do it.
This is some code from a previous question I answered where someone wanted to highlight a specific range whenever the word "Total" was found.
I changed the find to "Yes". Change the SearchRange to your column. (I think G is right).
Also, for future reference, Select should [almost never] be used.
It slows down code execution quite a bit and is not required.
I know the macro recorder likes to use it, but everything can be referenced without using select.
Brief example:
Sheets("ActiveJobStatus").Activate
Sheets("ActiveJobStatus").Cells(2, i).Select
ActiveSheet.Paste
Can Be replaced by:
Sheets("ActiveJobStatus").Cells(2, i).Paste
This code is working to copy the filtered data of "Award" column marked "Yes" to another sheet.
Sub CopyAwardsToActiveJobStatusSheet()
Dim SearchRange, First, Finder As Range
Dim PasteRow as Integer 'Add this to increment the rows we paste your data to
Set SearchRange = Sheets("MasterData").Range("G:G") 'Search This Range for "Yes"
Set Finder = SearchRange.Find("Yes") 'This is what we're looking for
If Finder Is Nothing Then Exit Sub 'We didn't find any "Yes" so we're done
'Drastically increases speed of every macro ever
'(well, when the sheets are modified at least - and it doesn't hurt)
Application.ScreenUpdating = False
First = Finder.Address 'Grab the address of the first "Yes" so we know when to stop
'Get the last row of column "A" on ActiveJobStatusSheet and start pasting below it
PasteRow = Sheets("ActiveJobStatus").Cells(Sheets("ActiveJobStatus").Rows.Count, "A").End(xlUp).Row + 1
Do
'Copy the entire row and paste it into the ActiveJobStatus sheet
'Column A and PasteRow (the next empty row on the sheet)
'You can change these if needed
Finder.EntireRow.Copy Sheets("ActiveJobStatus").Range("A" & PasteRow)
'If you just want A:G, you can use this instead:
'Finder returns the cell that contains "Yes",
'So we offset/resize to get the 6 cells before it and just copy that
'Resize doesn't like negative numbers so we have to combine:
'Finder.Offset(,-6).Resize(,7).Copy Sheets("ActiveJobStatus").Range("A" & PasteRow)
'Look for the next "Yes" after the one we just found
Set Finder = SearchRange.FindNext(after:=Finder)
PasteRow = PasteRow + 1 'Faster than looking for the end again
'Do this until we are back to the first address
Loop While Not Finder Is Nothing And Finder.Address <> First
'Clear MasterData
Sheets("MasterData").Range("A2:G" & Sheets("MasterData").UsedRange.Rows.Count).ClearContents
Application.ScreenUpdating = True 'Drastically increases speed of every macro ever.
End Sub
Just the code:
Sub CopyAwardsToActiveJobStatusSheet()
Dim SearchRange, First, Finder As Range
Dim PasteRow as Integer
Set SearchRange = Sheets("MasterData").Range("G:G")
Set Finder = SearchRange.Find("Yes")
If Finder Is Nothing Then Exit Sub
Application.ScreenUpdating = False
First = Finder.Address
PasteRow = Sheets("ActiveJobStatus").Cells(Sheets("ActiveJobStatus").Rows.Count, "A").End(xlUp).Row + 1
Do
Finder.EntireRow.Copy Sheets("ActiveJobStatus").Range("A" & PasteRow)
Set Finder = SearchRange.FindNext(after:=Finder)
PasteRow = PasteRow + 1
Loop While Not Finder Is Nothing And Finder.Address <> First
Sheets("MasterData").Range("A2:G" & Sheets("MasterData").UsedRange.Rows.Count).ClearContents
Application.ScreenUpdating = True
End Sub
Results:
MasterData Sheet:
ActiveJobStatus Sheet: