I have a list of references of cells to be deleted. The list of references is in sheet "test_url". The list of references point to cells to be deleted that are in another sheet "main_lists".
What I am after is a macro that takes all the references listed in "test_url" sheet, and select their cells in "main_lists" sheet and delete them.
The following macro is what I recorded for two references only in an attempt to demonstrate my problem that necessitated me to copy the reference from "test_url" sheet, then paste it in the NameBox of "main_urls" sheet to select the contents of the designated cell then delete its contents. This process was done manually one cell at a time for a list of 10-20 addresses/references. However, recently this list is over 2000 entries and it is growing:
Sub DeletePermittedCells()
'DeletePermittedCells Macro
Sheets("test_urls").Select
Range("B2").Select
Sheets("test_urls").Select
Selection.Copy
Sheets("main_lists").Select
Application.Goto Reference:="R200045C1"
Application.CutCopyMode = False
Selection.ClearContents
Sheets("test_urls").Select
Range("B3").Select
Selection.Copy
Sheets("main_lists").Select
Application.Goto Reference:="R247138C1"
Application.CutCopyMode = False
Selection.ClearContents
Sheets("test_urls").Select
End Sub
Can someone help with this issue please?
Try this one:
Sub DeletePermittedCells()
Dim rng As Range
Dim arr, c
With Sheets("test_urls")
'storing data in array makes your code much faster
arr = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
With Sheets("main_lists")
Set rng = .Range(arr(1, 1))
For Each c In arr
Set rng = Union(rng, .Range(c))
Next
End With
rng.ClearContents
End Sub
storing addresses in array (rather than reading each cell from worksheet directly) makes your code much faster.
Note, code assumed that your addresses stored in range B2:B & lastrow where lastrow - is row of last cell with data in column B
This assumes that the list of cells to be cleared in is column A:
Sub ClearCells()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, I As Long, addy As String
Set s1 = Sheets("test_url")
Set s2 = Sheets("main_lists")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For I = 1 To N
addy = s1.Cells(I, 1).Value
s2.Range(addy).ClearContents
Next I
End Sub
Related
this is my first post and I am super excited about it. I apologize in advance if my writing wouldn't make sense since I'm not super familiar with coding/programming terms.
Here is the Micro_Enabled_Excel_File which I'm using.
I have an excel file with multiple columns and rows. The number of rows will increase as time passes. I'm trying to filter two columns and copy the latest/most recent datapoint(row) and paste it in a new sheet to create a status report.
Excel Dataset: image
What the results would look like: image
What I have done so far:
Created a Micro to go through columns "SCOPE" and "TRADE NAME" to grab the unique entries and copy it into another sheet called "Code".
Sub First_COPY_STYLE_TO_REPORT()
'creating the Report sheet
Sheets("Report").Select
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("Status Updates").Select
Cells.Select
Selection.Copy
Sheets("Report").Select
ActiveSheet.Paste
Rows("2:1048576").Select
Application.CutCopyMode = False
Selection.ClearContents
End Sub
Created a Micro to create a template for sheet "Report" which will eventually be filled with the results of next Micro.
Sub Second_COPY_UNIQUE_TO_CODE()
'add title to filter columns in the Code sheet
Sheets("Code").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Filter1"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Filter2"
'creating the filter criteria also known as scope and trade name
'Finds Duplicates on SCOPE column and copies it to a new sheet called CODE
Sheets("Status Updates").Select
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Status Updates")
Set s2 = Sheets("Code")
s1.Range(Range("B2"), Range("B2").End(xlDown)).Copy s2.Range("A2")
s2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
'Finds Duplicates on NAME column and copies it to a new sheet called CODE
Dim s3 As Worksheet, s4 As Worksheet
Set s3 = Sheets("Status Updates")
Set s4 = Sheets("Code")
s1.Range(Range("C2"), Range("C2").End(xlDown)).Copy s2.Range("B2")
s4.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
'Clears formating and autofits column widths
Sheets("Code").Cells.ClearFormats
ThisWorkbook.Worksheets("Code").Cells.EntireColumn.AutoFit
End Sub
Created a Micro (Not Functioning) which includes two loops to filter two columns, sort the first column and copy and paste the second row of the sheet into the sheet "Report".
Sub Third_Generate_Latest_Status_Report()
Dim a1 As Long, a2 As Long, b1 As Long, b2 As Long
a1 = Cells.Find("Filter1").Offset(1, 0).Row
a2 = Cells.Find("Filter1").End(xlDown).Row
b1 = Cells.Find("Filter2").Offset(1, 0).Row
b2 = Cells.Find("Filter2").End(xlDown).Row
Dim g As Long, i As Long
For g = a1 To a2 'Look up for Filter1 column. Then loop through all criterias.
ActiveSheet.Range("$C$1:$J$300").AutoFilter Field:=2, Criteria1:=g
For i = b1 To b2 'Look up for Filter2 column. Then loop through all criterias.
ActiveSheet.Range("$C$1:$J$300").AutoFilter Field:=3, Criteria1:=i
'sort the NO column from largest to smallest (to get the latest/most recent update).
'I have copied this part of the code from the Micro I recorded.
ActiveWorkbook.Worksheets("Status Updates").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Status Updates").AutoFilter.Sort.SortFields.Add2 _
Key:=Range("C1:C300"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Status Updates").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
'I think I need to add code here to copy the row to sheet Report, and run the loop again
End With
Next i 'take next value in column Filter2
Next g 'take next value in column Filter1
End Sub
What I believe I need:
Sheet "Status Updates" - Filter "SCOPE" column and run through all criteria.Then,
Sheet "Status Updates" - Filter "TRADE NAME" column and run through all criteria.
Sort the "NO" column to get the most recent datapoint.
Copy the first row of data (meaning, the first row after the titles)
Paste it in another sheet called "Report".
Could you please take a look at my code and let me know what my mistakes are?
This is my first time coding/programming/using VBA.
Having an extra "code" sheet usually just makes things unnecessarily complicated. And because your "Status Updates" sheet is already sorted with Oldest updates to Newest updates, we know that for any given unique combo, you'll always want the bottom update. We can guarantee pulling that if we loop over your data backwards (from bottom row to first row, that's what the Step -1 does).
Then use a dictionary to check for unique combinations and pull the first encountered row (remember we're going backwards, so the first encountered row will be the latest update) for each unique combo and copy those rows over to your report sheet.
In the end, here's a fairly beginner friendly version of code for this task. I've commented it heavily for clarity so that you can follow along and understand what it does.
Sub tgr()
'Declare and set workbook and worksheet object variables
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsUpdt As Worksheet: Set wsUpdt = wb.Worksheets("Status updates")
Dim wsRprt As Worksheet: Set wsRprt = wb.Worksheets("Report")
'Declare and set a range variable that contains your data
Dim rUpdateData As Range: Set rUpdateData = wsUpdt.Range("A2:G" & wsUpdt.Cells(wsUpdt.Rows.Count, "A").End(xlUp).Row)
'Verify data actually exists
If rUpdateData.Row < 2 Then Exit Sub 'If the beginning row is the header row, then no data actually exists
'Use a dictionary object to keep track of unique Scope and Trade Name combos
Dim hUnqScopeTrades As Object: Set hUnqScopeTrades = CreateObject("Scripting.Dictionary")
'Declare your resulting Copy Range variable. This will be used to gather only the range of rows that will be copied over to the Report worksheet
Dim rCopy As Range
'Declare a looping variable
Dim i As Long
'Loop through each row in your Status Updates data. Because your updates are already sorted Oldest to Newest, begin at the end and loop backwards to guarantee newest updates are found first
For i = rUpdateData.Rows.Count To 1 Step -1
'Verify this Scope/Trade combo hasn't been seen before
If Not hUnqScopeTrades.Exists(rUpdateData.Cells(i, 2).Value & "|" & rUpdateData.Cells(i, 3).Value) Then
'This is a newly encountered unique combo
'Add the combo to the dictionary
hUnqScopeTrades(rUpdateData.Cells(i, 2).Value & "|" & rUpdateData.Cells(i, 3).Value) = i
'If this is the first unique combo found, rCopy will be empty, check if that's the case
If rCopy Is Nothing Then
'rCopy is empty, add the first found unique combo to it
Set rCopy = rUpdateData.Cells(i, 1)
Else
'rCopy is not empty, add all additional unique combos with the Union method
Set rCopy = Union(rCopy, rUpdateData.Cells(i, 1))
End If
End If
Next i
'Clear previous results (if any)
wsRprt.Range("A1").CurrentRegion.Offset(1).Clear
'Verify rCopy isn't empty and then copy all rows over
If Not rCopy Is Nothing Then rCopy.EntireRow.Copy wsRprt.Range("A2")
End Sub
I have code that creates a bunch of new sheets, names them, and then loops through them searching a dataset for the name of the sheet and transposing data rows with a value matching the name of the sheet.
I've gotten it to work transposing each row to the next column to the right, but for printing purposes, I'd like it to move to the bottom of the last pasted cell, skip a row (or better yet, insert a page break), and then paste the next one.
Something about the way I've tried to tell it to count the rows, move down, and then start again, isn't working. It appears to be pasting multiple times over previously pasted data.
I've tried several different ways of counting the rows and adding a row, or inserting a page break, but I can't get it working. I thought maybe I needed to move the rowcount function out of the IF statement, but that didn't work either.
Sub Franchise_Data4()
'searches Raw Data sheet for the Franchise ID associated with each sheet name; then transposes each relevant row onto the associated sheet'
Dim Scol As Range, Cell As Object, rawdata As Worksheet, ws As Worksheet, lc As Long, rowcountA As Integer, startR As Integer, labels As Range
Set rawdata = ThisWorkbook.Worksheets("Raw Data")
Set Scol = rawdata.Range("$C$2:$C$2000") 'Franchise ID column on Raw Data sheet'
Set labels = ThisWorkbook.Worksheets("Raw Data").Range("A1:AZ1")
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Raw Data" And ws.Name <> "Pivot" Then
With ws 'cycles through all of the sheets with Franchise ID's as the name
startR = 0
For Each Cell In Scol 'should scan the C column on the Raw Data sheet'
If IsEmpty(Cell) Then Exit For
If Cell.Value = ws.Name Then 'checks for cells that contain the same Franchise ID as the current sheet in the cycle'
Cell.EntireRow.Copy
ws.Cells(startR + 1, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=True
labels.Copy
ws.Cells(startR + 1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=True
End If
rowcountA = Cells(Cells.Rows.Count, "A").End(xlUp).Row
startR = rowcountA + 1
Next
End With
End If
Next ws
Application.CutCopyMode = False
End Sub
It appears to paste the first data set correctly, then move down 1 row (instead of the rowcount+1) and paste again. Then I guess it either stops, or it continues pasting the rest in the same spot.
You need to fully qualify the Worksheet that the Cells are on.
rowcountA = Cells(Cells.Rows.Count, "A").End(xlUp).Row
There's an implicit ActiveSheet here, not a reference to ws as you would want. You already have a With ws...End With so change this line to:
rowcountA = .Cells(.Rows.Count, "A").End(xlUp).Row
Note that there are other instances where you are "repeating" the ws instead of fully taking advantage of the With ws...End With.
I have a macro-enabled spreadsheet that allows me to hide various columns and rows based on certain criteria I select and trigger on the sheet.
First I select the relevant columns by marking that column with a "Y", and hiding the remaining columns with a "N" with the following routine:
Sub Hidecolumn()
Dim p As Range
For Each p In Range("H1:BN1").Cells
If p.Value = "N" Then
p.EntireColumn.Hidden = True
End If
Next p
End Sub
Please note that Columns("A:G") will always be visible. Only Columns("H:BN") can be hidden based on the above. This works perfectly.
Then, I will hide the the various rows that do not have a value in the remaining visible columns for Columns("H:BN"), which is 59 possible columns. If any column within that row has a value, then that row will remain visible. If there are NO values in any of the visible columns for that row, then I hide that row. It is entirely possible that the 59 columns could reduce to 7. I do this with the following routine:
Sub HideRowsSecond()
Module2.Unhiderow
Dim srcRng As Range, ws As Worksheet
Set ws = ActiveSheet
Set srcRng = ws.Rows("5:" & ws.Cells(ws.Rows.Count, 4).End(xlUp).Row)
Dim R As Range, hideRng As Range
For Each R In srcRng
If Application.CountA(R.Columns("H:BN").SpecialCells(xlCellTypeVisible)) = 0 Then
If hideRng Is Nothing Then
Set hideRng = R.EntireRow
Else
Set hideRng = Application.Union(hideRng, R.EntireRow)
End If
End If
Next R
If Not hideRng Is Nothing Then hideRng.EntireRow.Hidden = True
MsgBox ("Complete")
End Sub
Please note that the starting row is Row("5"), and we use Column("D") as the counting column because it has a value in every cell down to the bottom of the data set. This works perfectly.
Now that I have my desired data set, I need to save this visible data set to a new XLSX file that the user can name themselves and save in the directory of their choice. The target range will begin with cell "C3" and we need to save however many visible columns there are to the right and however many visible rows there are down to the bottom of the data set.
Can someone please help me with this final step?
Here is the solution.
Sub exportToFile()
Dim rng As Range
With ActiveSheet
Set rng = Application.Intersect(.UsedRange, .Cells.Resize(.Rows.Count - 2, .Columns.Count - 2).Offset(2, 2))
End With
rng.Select
rng.SpecialCells(xlCellTypeVisible).copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A" & Row & ":N" & Row).EntireRow.AutoFit
ActiveSheet.Range("A1").Select
Application.Dialogs(xlDialogSaveAs).Show ("c:\")
End Sub
I am working on a Macro in Excel that will make a copy of the current worksheet and paste the values into a new worksheet. The worksheet name would be the same just with a number after it [ie Sheet, Sheet1(2)]
My code does this correctly except that it copies and pastes everything to Sheet1(2). I only want it to paste the values (not formulas) from Sheet1 to Sheet1(2). I'm a novice at vba at best so any suggestions are greatly appreciated.
Sub SPACER_Button4_Click()
' Compile Button to Generate Quote
'
'variables definitions
ActiveSheetValue = ActiveSheet.Name
'
'This section creates a copy of the active worksheet and names it with the next corresponding number
Sheets(ActiveSheetValue).Copy After:=Sheets(ActiveSheetValue)
'This section should look for X value in each row, column 4. If value equals X, it deletes the row on the copied sheet
Dim i As Integer
i = 26
Do Until i > 300
If ActiveSheet.Cells(i, 11).Value = "X" Then
Rows(i).Delete
Skip = True
End If
'
If Skip = False Then
i = i + 1
End If
'
Skip = False
Loop
'This part hides columns on Right K thru R of new copied sheet
Sheets(ActiveSheet.Name).Range("K:R").EntireColumn.Hidden = True
End Sub
If the data is contiguous, consider creating a new sheet, selecting and copying the range of data, and pasting onto the new sheet using the below code.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
I use something like this:
Sub KopyKat()
Dim s1 As Worksheet, s2 As Worksheet
Dim r As Range, addy As String
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
For Each r In s1.UsedRange
If r.Value <> "" Then
If Not r.HasFormula Then
addy = r.Address
r.Copy s2.Range(addy)
End If
End If
Next r
End Sub
I am attempting to create a loop but running into a slight snag that I cannot seem to figure out how to fix; hoping that someone can help me.
I have a list of names in Sheet1 Column A that I would like to use their values as the Sheet names when the loop is running.
Example:
Dim Name As String
Names = Sheets("Sheet1").Range("A1").value
But instead of it sticking with Range("A1").Value, I am needing it to swing down the list until it hits a blank row. I found a few different syntax/coding and tried to make it work but got stuck here.
With a list of names in Column A, the code will run directly to the bottom of the list, pull the value of the name and go directly to the that sheet.
Example:
List in Column A:
Mark
John
Jason
The code will grab Jason, go to the Jason worksheet, and enter the formula. However, it skips Mark and John. Not sure how to fix from here.
Any help would be greatly appreciated.
Sub RunTest()
Dim i, lastcell As Long
Dim Name As String
lastcell = Range("A" & Cells.Rows.Count).End(xlUp).Row
Name = Range("A" & Cells.Rows.Count).End(xlUp).Value
Range("A1").Select
For i = 1 To lastcell
Sheets(Name).Select
Range("A1").Select
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "=2"
Sheets("sheet1").Select
ActiveCell.Select
ActiveCell.Offset(1, 0).Select
Next I
End Sub
There's no need for all of that select/activate.
Sub RunTest()
Dim c As Range, wb As Workbook, sht As Worksheet
Set wb = ActiveWorkbook
Set sht = ActiveSheet
For Each c In sht.Range(sht.Range("A1"), _
sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If c.Value <> "" Then
wb.Sheets(c.Value).Range("C1").Formula = "=2"
End If
Next c
End Sub
You need to delete the row: Range("A1").Select
the row with the Name must be moved directly to the loop.
For i = 1 to lastcell
name = cells(i,1)
next i
Name = Range("A" & Cells.Rows.Count).End(xlUp).Value ' - this expression chooses the last name, You can delete it