Printable View
Thanks Sam, I should have been more pedantry in my wording.
@ Jett I was trying to point out that copying modules and renaming them keeps a copy of the routines in both modules. These 'old' routines should be renamed (or deleted) otherwise you will get an Ambiguous Name error.
paulked - thank you so much again for your continued help with this! You are correct in assuming i needed the data to be shown in a new sheet so then people on my team can name it whatever when they send out to others. I had to make a couple tiny tweaks to make it work though which i highlighted below for anyone to have should this post be useful to them :). had 2 bugs, 1) VBA debugger would pop up and alert that there was no sheet named "URL List 1", so i add logic to create the sheet if it doesn't exist in probably the worst way ever considering how streamlined your code is, but hey it works! 2) i had to change the part that deletes the blank rows to column D instead of C because of the new inserted column in A. This works perfect though sir! I also added at the very end a way to delete the temp sheet the vba was using so i dont have two identical tabs. This is sooo freaking fast, i still am dumb founded and impressed how fast you made this script. Thank you like x100!
Code:Sub GetURLs003() Application.ScreenUpdating = False
Dim ar As Variant, Meta As String, shMeta As Worksheet, shDest As Worksheet
Dim i As Long, j As Long, ar1() As Variant, e As Long, lr As Long
Dim TempSheet As String
Dim checkSheetName As String
TempSheet = "URL Temp Sheet"
'Get source sheet name
If Len(Range("A6")) < 2 Then
Meta = InputBox("Please Enter the tab name for your Metadata")
Range("A6") = Meta
Else
Meta = Range("A6")
End If
'Check sheet exists
On Error Resume Next
Set shMeta = Sheets(Meta)
On Error GoTo 0
If shMeta Is Nothing Then MsgBox "That sheet doesn't exist!": Exit Sub
On Error Resume Next
checkSheetName = Worksheets(TempSheet).Name
If checkSheetName = "" Then
Worksheets.Add.Name = TempSheet
'MsgBox "The sheet named ''" & TempSheet & _
'"'' does not exist in this workbook but it has been created now.", _
'vbInformation, "Intouch SEO Automation for Excel"
Else
'MsgBox "The sheet named ''" & TempSheet & _
'"''exist in this workbook.", vbInformation, "Intouch SEO Automation for Excel"
'Worksheets(TempSheet).Activate 'Selects worksheet
'ActiveSheet.UsedRange.Delete 'deletes the used range of cells to clear the sheet
'Range("a1").Select
End If
'Set sheet names
Set shDest = Sheets(TempSheet)
'Put source int array
ar = shMeta.UsedRange
'Loop through data and write to new array ignoring formula errors on data page!
For i = 8 To UBound(ar, 1)
For j = LBound(ar, 2) To UBound(ar, 2)
If LCase(Left(ar(i, j), 10)) = "site page:" Then
On Error GoTo Nxt
e = e + 1
ReDim Preserve ar1(4, e)
ar1(1, e) = ar(i, j)
ar1(2, e) = ar(i, j + 1)
End If
If LCase(Left(ar(i, j), 8)) = "page url" Then
On Error GoTo Nxt
ar1(3, e) = ar(i, j)
ar1(4, e) = ar(i, j + 1)
End If
Nxt:
On Error GoTo -1
Next
Next
On Error GoTo 0
'Clear destination sheet and write new array
With shDest
.Cells.ClearContents
.Range("A1:E" & UBound(ar1, 2) + 1) = WorksheetFunction.Transpose(ar1)
'Delete unwanted column
.Columns("D:D").EntireColumn.Delete
'Add headers
.Range("A1") = Format(Now, "m/d/yyyy h:mm:ss AM/PM")
.Range("B1") = "Page #"
.Range("C1") = "Page Name"
.Range("D1") = "Page URL"
.Range("E1") = "Notes"
'Delete blank data rows
lr = .Cells(Rows.Count, 2).End(3).Row
.Range("D1:D" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
'Add a new sheet and copy new data to it
With Sheets.Add
.Name = "URL List" ' & Format(Now, "DD-MMM HH.MM")
.Tab.Color = vbGreen
shDest.Range("A1").CurrentRegion.Copy .Range("A1")
.Columns("A:E").Columns.AutoFit
End With
Sheets("URL List").Activate
'Delete temp sheet
Application.DisplayAlerts = False
Worksheets(TempSheet).Delete
Application.DisplayAlerts = True
End Sub
Great stuff. I didn't put a check in for the URL List 1 sheet as I was creating a new sheet so assumed it would always be there :whistle:
For your next part, comparing the two sheets, I have a better way of selecting the Old and Newest sheets the user wants to compare. I'll pop that routine in here later on or tomorrow morning.
One question before I do that, Is the sheet just generated always the latest one to compare with old data?
Using this should eliminate any typing errors when the user needs to input a sheet name.
The instructions of how to implement the code are included in the workbook. Image of sheet entry:
Attachment 26609
Interested for sure, and to answer your question - yes. Thanks again for all your help here sir!
In that case mymetadataInputValue2 = "URL List 1", no need for user input :)
:clap2: paulked - you da f****** man! I have learned so much from this stepped approach of the knowledge share my friend. I am blown away how much more efficient and effective these coding best practices are. Id be willing to tip you for your time sir, this has not only helped me complete my task, but go above and beyond and landed me a new opportunity within my company by telling my boss today that it went from 86 secs to under 1 second by reaching out to smarter fellows than myself on this forum. Now they going to reach out to the company wide to see what i can help automate, and help change my workload to at least 10% VBA problem solving tasks like i been wanting really bad lately vs client work wheel spinning work that i have my associate do most of. This all thanks to you being kind and helping me out paulked! :yes :clap:. I did some reading about arrays in VBA and some reviewing of declaring variables best practices and your code is making a lot more sense. And hoping i can use this info to better optimize all my scripts.
I will upload the final workbook tomorrow after i compile that bad ass sheet selector into the code and i really appreciate the clear guidance on that too man!
:Post tags for others (these are some of my google searches i made from my browser history trying to create this VBA Automated Solution): VBA cells with text that contain, VBA Find cells with text that contain, auto find cells with text, search rows for cells that contain specific text, excel vba find value in column, find text in cell excel vba, for next loop vba find cell value control, vba cells.find search direction, vba find 2 adjacent cells with specific text, copy and paste, vba find cell with specific text, vba find cell with string select 1 extra column and row below, vba macro to find text offset column/row and copy, vba to find all text that contains and copy to new sheet, vba to find and copy 1st match to new sheet, vba to find and copy all that match to new sheet, vba to find and select all that match, vba to find cell containing text, vba to find cell that contains and copy to new sheet, vba to find text in a cell.
Shoot me an email if interested in that $ tip or to chat offline - thank you so much again! I personally am shocked how kind this community is here.
That's great news! This is a brilliant forum and it's great to help people, the bonus for me is gaining more knowledge of VBA and making my, and hopefully others, life easier... no need for tips!
Best of luck in your pursuits and we're always here when you need us :thumb
@Paulk
Why not simply Data Validation ?
It is selected during macro run (it was through an input box). It could, of course, be selected 1st!
As promised above - here is the final version of my workbook with the handy sheet selector form paulked(you are amazing!) provided - again - many thanks to all your help. :yes Link to final workbook -> https://drive.google.com/file/d/1nsn...ew?usp=sharing
paulked :bow: - i rolled this out to my team in a handy little auto-setup tool(https://drive.google.com/open?id=1y0...STZdRLriA_JKNH), which worked great. But of course, all users are creative and found some special use cases here - is there anyway to modify the VBA that scans through the rows looking for text that contains, to only search visible rows? so if someone has a page hidden, it would not be pulled into the generated URL list? Any thoughts or directions here would be greatly appreciated
That's all great, I'm really pleased it's worked out for you. To exclude the hidden cells try adding the bit in red:
I haven't tested it, but it could do the trick!!Code:ar = shMeta.UsedRange.SpecialCells(xlCellTypeVisible)
Tried that, for some reason it is getting hung up on the 3rd line after the comment "'Clear destination sheet and write new array"
.Range("A1:E" & UBound(ar1, 2) + 1) = WorksheetFunction.Transpose(ar1)
It would be great if you could lead me to an article or two or explain this array script to me so I can troubleshoot this, sorry to be a pest..
It worked ok for me, see attached file (and yes, it is 02:30!).
File won't upload so here's a link
snb has a great site http://www.snb-vba.eu/VBA_Arrays_en.html
Lol, ima try this in a min when I get home for sure bro, thanks!
FYI- here my time zone rn.
Central Daylight Time
Time zone in Johnson County, KS (GMT-5)
Wednesday, May 20, 2020, 9:42 PM
Just tried it again and having the same issue. To confirm, if you hide rows say rows 12-19 or 66-72, you do not get a VBA runtime error? or an incomplete list that stops at row 72? Thanks for the resource sir! i will look into first thing (on my side of the world) and see if i can figure it out. You have been so helpful! :thumb: pray2::bow::clap:
I've seen the error! I'll have a look into it.
Okay, think I've got it. Add a 'Helper' sheet and name it Help (you can hide it if you wish) then replace
withCode:ar = shMeta.UsedRange.SpecialCells(xlCellTypeVisible)
Hope that works for you, worked for me hiding either of those groups of rows you mentioned and both together.Code:Sheets("Help").Cells.ClearContents
shMeta.UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets("Help").Range("A1").PasteSpecial xlPasteValues
ar = Sheets("Help").UsedRange
So yes, this worked for the example I provided, however one of my own client workbooks it is throwing error after I added script to check if the sheet exists, if not creates and hides, all with no prompts. Same bit of code used for creating the URL List tab but with all prompts removed, and inside the first script In the module that sets up the URL Wizard. So I spent an hour today reading on the site you shared. I do love the way that person writes there content very much. And gave me ALOT of useful information and tips. Led me to the bigger solution here, which is creating an ADD-IN that I can remotely update so all 23 peeps don't have to redo the work we required to be done by today lol. The biggest issue found was the searching for rows started at row 8, not like 2 (Which I changed to after reading about the code you created paulked :)_)
Here is the workbook with issues - again, still not able to upload...
The problem, is the sheet does not populate any data with the last two modifications. I need for users to be able to drag and drop into workbook, hit F5 into the first block of VBA to setup UX buttons and use from there. however i cant figure out how to make this thing work, as i don't get the purpose of the Temp Sheet and the Helper Sheet, and why adding the same block of code works but does not in certain areas of the code. I tried adding to end, first, etc. Not working :/ As always, any help is really - greatly appreciated!
I'm sorry, but my time is limited at the mo so this is a 'quick fix'.
You can't write a multi-range eg Range("C5:E9,G9:H16,B14:E18") to an array (I don't think!), therefore you must copy that multi range to an area and then use that area to write to the array.
Try this (my changes are in red):
Code:Sub GetURLs003()
'SPEEDY CODE
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim ar As Variant, Meta As String, shMeta As Worksheet, shDest As Worksheet
Dim i As Long, j As Long, ar1() As Variant, e As Long, lr As Long, tm#
Dim TempSheet As String
Dim checkSheetName As String
tm = Timer
TempSheet = "URL Temp Sheet"
'Get source sheet name
If Len(Range("A6")) < 2 Then
Meta = GetSh("Please Enter the tab name for your Metadata")
Range("A6") = Meta
Else
Meta = Range("A6").Value
Result = MsgBox("Would you like to continue to use the worksheet named below?" & vbCrLf & vbCrLf & Meta, vbYesNo + vbQuestion)
If Result = vbYes Then
Meta = Range("A6")
Else:
Meta = GetSh("Please Enter the tab name for your Metadata")
Range("A6") = Meta
End If
End If
'Check sheet exists
On Error Resume Next
Set shMeta = Sheets(Meta)
On Error GoTo 0
If shMeta Is Nothing Then MsgBox "That sheet doesn't exist!": Exit Sub
'
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
'
On Error Resume Next
checkSheetName = Worksheets(TempSheet).Name
If checkSheetName = "" Then Worksheets.Add.Name = TempSheet
checkSheetName = ""
checkSheetName = Worksheets("Helper").CodeName
If checkSheetName = "" Then
Worksheets.Add.Name = "Helper"
Worksheets("Helper").Visible = xlHidden
End If
On Error Goto 0
'
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
'
'Set sheet names
Set shDest = Sheets(TempSheet)
'Put source int array
Sheets("Helper").Cells.ClearContents
shMeta.UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets("Helper").Range("A1").PasteSpecial xlPasteValues
ar = Sheets("Helper").UsedRange
'Loop through data and write to new array ignoring formula errors on data page!
For i = 2 To UBound(ar, 1)
For j = LBound(ar, 2) To UBound(ar, 2)
If LCase(Left(ar(i, j), 10)) = "site page:" Then
On Error GoTo Nxt
e = e + 1
ReDim Preserve ar1(4, e)
ar1(1, e) = ar(i, j)
ar1(2, e) = ar(i, j + 1)
End If
If LCase(Left(ar(i, j), 8)) = "page url" Then
On Error GoTo Nxt
ar1(3, e) = ar(i, j)
ar1(4, e) = ar(i, j + 1)
End If
Nxt:
On Error GoTo -1
Next
Next
On Error GoTo 0
'Clear destination sheet and write new array
With shDest
.Cells.ClearContents
.Range("A1:E" & UBound(ar1, 2) + 1) = WorksheetFunction.Transpose(ar1)
'Delete unwanted column
.Columns("D:D").EntireColumn.Delete
'Add headers
.Range("A1") = Format(Now, "m/d/yyyy h:mm:ss AM/PM")
.Range("B1") = "Page #"
.Range("C1") = "Page Name"
.Range("D1") = "Page URL"
.Range("E1") = "Notes"
'Delete blank data rows
'On Error Resume Next
lr = .Cells(Rows.Count, 2).End(3).Row
On Error Resume Next
' next line errors if no blank rows!!!
.Range("D1:D" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End With
'Add a new sheet and copy new data to it
With Sheets.Add
.Name = "URL List " & Format(Now, "HH.MM.ss AM/PM")
.Tab.Color = vbGreen
shDest.Range("A1").CurrentRegion.Copy .Range("A1")
.Columns("A:E").Columns.AutoFit
End With
'Sheets("URL List").Activate
'Delete temp sheet
Application.DisplayAlerts = False
Worksheets(TempSheet).Delete
Application.DisplayAlerts = True
'SPEEDY CODE
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
'ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationAutomatic
Debug.Print Timer - tm
End Sub
BTW, can you get rid of those functions in Module 1? They add minutes to running a code that normally takes a couple of seconds!