Need help copying cells from one sheet to another..

[JETTLIFE]

I am struggling so hard! Please help me! :crying::crying:[
Version of the program


Microsoft Excel for Office 365 ProPlus – Excel version: 1908

What I need it to do:I need a VBA macro that will create a new sheet with all Page names, Page Numbers, and Page URLs from another sheet.
In theory it would work something like this: the vba code will find the first cell with text that contains “Site Page” select that cell and the cell next to it that starts with “Page Name”; AND find the next cell under the Site Page that contains “Page URL” select that cell and the cell next to it on the right with the actual URL. Copy the selection range and paste into a new sheet titled “FINAL URL LIST” in the next empty row.
Few key things it needs to do.


When first running the code, it needs to check if the sheet “Final URL List” exists, if it does, then clear it all and add Date and time stamp into A1. If does NOT exist, then create the tab, and add Date and time stamp into A1
Metadata tab layout changes from user to user based on there preference, so the VBA code cannot rely on find first instance, and offset copy. It needs to dynamically search for Site Page # to select and then the Page URL to select then copy and paste
The sheet named “Final URL List” will exist in all variations of the workbook.
The document is setup for SEO to create search engine listing text per webpage, and Social Media to set the OG sharing tags. We only want to grab the Site Page line that is correlated to the SEO metadata and not Open Graph stuff. So the vba will need to skip every other found row with text that contains “Site Page:”

Sample data (before and after sample worksheets, added as attachments)

Below is the workbook i have been trying to get to work – I have gotten the code close to working a few times, but then the loop will run away, or It will copy but not paste. Weird stuff keeps happening and I am begging for help!


Here is the workbook -> 26358




Here is the VBA i have so far for searching the sheet for cells that contain "site page", selecting that cell and the 1 to the right, copying and pasting to new sheet.


Sub LoopThroughUntilBlanks2()'this one is getting really close, just not pasting right
'UpdatebyExtendoffice20161222
' Select cell A2, *first line of data*.
Dim xrg As Range
Dim textToSearchFor As String
On Error Resume Next

Set xrg = Range("a2")
Worksheets("HD metadata").Activate
xrg.Cells(2, 0).Select ' Set Do loop to stop when 3 consecutive empty cells are reached.
' Application.ScreenUpdating = False


Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
' Insert your code here.



textToSearchFor = "site page:"


Cells.Find(What:=textToSearchFor, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select

'Select and copy addtinoal cells to the found cell
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Copy
'Selection.Copy


'copy the selection to last empty row of another worksheet

Worksheets("sheet2").Activate
'find the last row of data in the worksheet, and paste below
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
Worksheets("HD metadata").Activate
' Step down 2 rows from present location.
ActiveCell.Offset(2, 2).Select
Loop
MsgBox ("empty")
'Application.ScreenUpdating = False

End Sub

Here is an example of the basic output I need -> https://i.imgur.com/Kf2E7xf.jpg
To make it absolutely perfect -> Here is an example of how the data could be processed to really help users read through by putting the data into a table -- screenshot (https://i.imgur.com/cihB0eq.jpg)
2635926360

Here is the VBA i have for chgecking if a specific worksheet exist, and if not, creates one, if it does exist, it clears and sets datea and time in A1 - this is fully working, but im not sure how to combine the VBA.

Function CreateSheetIf(strSheetName As String) As BooleanDim wsTest As Worksheet
CreateSheetIf = False
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0

If wsTest Is Nothing Then
CreateSheetIf = True
Worksheets.Add.Name = strSheetName
End If
End Function
Sub Test()
'Create worksheet "Bob" if it doesn't exist. Display Message box if
'sheet is created.
If CreateSheetIf("FINAL URL LIST") Then
MsgBox ("Welcome to the workbook Bob!")
End If




End Sub

Politeness and gratitude

This is my first time posting, even though I have relied on these forms to help me forever I hope someone can actually help with this specific need. I will be in forever debt to you as you will save my sanity and I will be obligated to begin contributing if someone can pretty please help me! I would appreciate any help at all!

Please let me know if you have any suggestions, can help, or see errors. Thank you so much for anyone who helps!

[jolivanes]

You could start by being polite and get rid of all the shouting (Bold, larger font etc)
Change the wording of "Desperate - Need help copying cells from one sheet to another... PLEASE HELP!!"also
It is a safe bet that pretty close to 100 percent of people here come here to get help. Would you go into Google for help and type: "Desperate, need help".
The middle part is sufficient.

[SamT]

Obviously, I can't test this, because you have no data to test with, but it does compile.
I suggest that you place this code in a Module named "URLTable", along with any other code specific to the FINAL URL LIST sheet.
Option Explicit

Public Const URLtableSht As String = "FINAL URL LIST"


Sub Make_URLtablesht()

Dim SiteNameCell As Range
Dim FinalURLtable
Dim i As Long

UseSpeedyCode True
ClearMakeSheet URLtableSht

ReDim FinalURLtable(0 To SitePagesCount, 1 To 3)

FinalURLtable(0, 1) = "Page #"
FinalURLtable(0, 2) = "Page Name"
FinalURLtable(0, 3) = "URL"

Set SiteNameCell = Sheets("Metadata").Range("A7")
FinalURLtable(0, 1) = Split(SiteNameCell, ":")(1)
FinalURLtable(0, 2) = Split(SiteNameCell.Offset(, 1), ":")(1)
FinalURLtable(0, 3) = Split(SiteNameCell.Offset(1, 1), ":")(1)


For i = 2 To UBound(FinalURLtable, 1)
Set SiteNameCell = NextSiteNameCell(SiteNameCell)
FinalURLtable(0, 1) = Split(SiteNameCell, ":")(1)
FinalURLtable(0, 2) = Split(SiteNameCell.Offset(, 1), ":")(1)
FinalURLtable(0, 3) = Split(SiteNameCell.Offset(1, 1), ":")(1)
Next

Sheets(URLtableSht).Cells(1).Resize(UBound(FinalURLtable, 1), UBound(FinalURLtable, 2)) = FinalURLtable

UseSpeedyCode False
End Sub

Private Function NextSiteNameCell(StartCel As Range) As Excel.Range
With Sheets("Metadata")
Set NextSiteNameCell = .Range("A:A").Find(What:="Site Page", After:=StartCel, LookAt:=xlPart)
End With
End Function

Private Function SitePagesCount() As Long
With Sheets("Metadata")
SitePagesCount = WorksheetFunction.CountIf(.Range("A:A"), "Site Page:*")
End With
End Function
Sub TestSitePagesCount()
Dim X
X = SitePagesCount
End Sub

Then paste this code into a module named "Globals"
Option Explicit

Public Sub ClearMakeSheet(shtname As String)
If ShtExists(shtname) Then
ThisWorkbook.Sheets(shtname).Cells.ClearContents
Else
ThisWorkbook.Worksheets.Add.Name = shtname
End If
End Sub

Public Function ShtExists(shtname As String) As Boolean
On Error Resume Next
ShtExists = (LCase(ThisWorkbook.Sheets(shtname).Name) = LCase(shtname))
On Error GoTo 0
End Function

Public Function UseSpeedyCode(GoFast As Boolean)
Dim Calc As Long
With Application
.ScreenUpdating = Not GoFast
.EnableEvents = Not GoFast
If GoFast Then
Calc = .Calculation
.Calculation = xlCalculationManual
Else
.Calculation = Calc
End If
End With
End Function

Public Sub ShowAllSheets()
Dim sh
For Each sh In ActiveWorkbook.Sheets
sh.Visible = xlSheetVisible
Next
End Sub

[rlv]

Cross posted here:

https://www.mrexcel.com/board/threads/desperate-need-help-copying-cells-from-one-sheet-to-another-please-help.1131129/

[JETTLIFE]

HEy Jolivanes, i apologize if i came across rude or no polite in anyway. That was not my intentions here at all. I was simplying trying to break apart my message with key headings and attention getting title. I will edit post to fix this and appreciate you letting me know

[JETTLIFE]

Hey SamT! Thank you so so so much for reaching out with a solution here. I am very sorry for not providing any example data.
Here is a workbook full of example data -> It is 5.0mb due to pictures for the metadata so here is a link to the file in my AWS S3 cloud -> https://cloud.jettlifetech.com/excel-vba/MetaCheck+3.1+(HD)+-+sample+data+workbook.xlsm
Here is a highly compressed one with all other functions removed and stripped bare to send through this forums attachment manager. --> 26392

I tried setting up the code you provided, but I keep getting an error on "FinalURLtable(0, 1) = Split(SiteNameCell, ":")(1)" and your code is very clean but complex for me to understand or debug. Hopefully you can help explain? Again, i really appreciate the help here!

[SamT]

:banghead::banghead::banghead::banghead: My bad...


Set SiteNameCell = Sheets("Metadata").Range("A7")
FinalURLtable(1, 1) = Split(SiteNameCell, ":")(1)
FinalURLtable(1, 2) = Split(SiteNameCell.Offset(, 1), ":")(1)
FinalURLtable(1, 3) = Split(SiteNameCell.Offset(1, 1), ":")(1)


For i = 2 To UBound(FinalURLtable, 1)
Set SiteNameCell = NextSiteNameCell(SiteNameCell)
FinalURLtable(i, 1) = Split(SiteNameCell, ":")(1)
FinalURLtable(i, 2) = Split(SiteNameCell.Offset(, 1), ":")(1)
FinalURLtable(i, 3) = Split(SiteNameCell.Offset(1, 1), ":")(1)
Next

Forgot to edit after CopyPasta.

FinalURLtable is Redimmed to a 2D Array, with 1 more "Row" than the number of Sites. (the array's "Rows" count starts at zero. It has 3 "Columns", numbered from 1 to 3.

Accessing data "slots" in an array is just like accessing Cells in Excel: ie (row Number, column Number). I used "Row" zero for the headers and "Row" 1 for the first Sites data.

The Find Method in NextSiteNameCell starts at the previous Site's cell, which is why I couldn't use the Function on the first site.



Edit To add. OH NO!!!!:bug:
The real Workbook is very different in structure from what you attached in your first post. You can live with the results provided or You can divide the Site count by two and add a Find next to the Function NextSiteNameCell

[JETTLIFE]

Hey SamT - i appreciate your help on this, however i was unable to get what you sent over to work. I eventually got it though - with this vba code below, however i was wondering if someone could help me clean it up? Make it run faster?

What the VBA needs to do?
Search worksheet for cells that contain specific text, in this case "Site Page" and selects that cell, and offset selects the cell to the right. Then copies into a new tab that is generated if it does not exist, it does exist, it will clear, then page the copied text. After looping all rows and copying all over to new tab. then it de-dups that list because every other row it found i did not need copied due to it being exact same. Then it repeats the process looking for "Page URL" this time and pastes that into the new sheet. So the output is a table of Site Page #, PAge Names, and Page URLs You can view an example of the output in the attached workbook below on worksheet "URL LIST 1".

For some reason i cant attach a workbook - so here is a link to a workbook with real life data in it and my URL Wizard working (https://cloud.jettlifetech.com/excel-vba/SampleURLWizard.xlsm) -> https://cloud.jettlifetech.com/excel-vba/SampleURLWizard.xlsm



Sub GetURLs002()
'************************************************************************** ****************************************************
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
'------------------------------------------------------------------------------------------------------------------------------
'++++++++++++++++++> MACRO BLOCK START <++++++++++++++++++
'
'>> Short Summary: this VBA will get all URLs, page names, and numbers from a worksheet the user defines from a prompt.
'
'
' >>>>>>>>>> How does it work? <<<<<<<<<<<<<<<<
'
'-> Step 1: prompts for user input to enter what the metadata sheet is called and stores as variable on "URL Wizard" sheet
'-> Step 2: checks if the worksheet "URL List 1" exist, if not it will create it, if so - it will clear used space
'-> Step 3: then searches for cells with text that contain "site page:" copy/paste into URL List 1 worksheet
'-> Step 4: then it de-dupes that list
'-> Step 5: then it searches for cells with text that contain "page url" copy/paste into URL List 1 worksheet
'-> Step 6: formats URL List 1 output as table with date and time stamp of when it was created
'-> Step 7: adds color to the tab
'
'------------------------------------------------------------------------------------------------------------------------------
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
''************************************************************************* *****************************************************
'
' START ------------------>
'
'************************************************************************** ****************************************************
'
'Speed up code processing time
Application.ScreenUpdating = False
'Application.DisplayStatusBar = False
Application.EnableEvents = False
'ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual




'Excel objects.
Dim m_wbBook, myworkBK As Workbook
Dim metadataWB, FinalURL, URLhelper As Worksheet
Dim m_rnCheck As Range
Dim m_rnFind As Range
Dim m_stAddress As String
Dim textToSearchFor, textToSearchFor2 As String
Dim mymetadataInputValue, UserDefinedMetadataTabName As String
Dim LResult As String
Dim UserInput03 As Object
Dim VBAhelperSheet, VBAurlHelper2 As String
Dim mySheetName As String
mySheetName = "URL List 1"
VBAurlHelper2 = "URL Wizard"




Dim LatestURLChanges As String, mySheetNameTest As String
LatestURLChanges = "URL List 1"


'Set Variables
Set m_wbBook = ThisWorkbook
Set myworkBK = ThisWorkbook
Set URLhelper = myworkBK.Worksheets(VBAurlHelper2)


myworkBK.Worksheets(VBAurlHelper2).Activate

'<******************************************* START *************************************************************************** *********************************************
'------------------------------------------------------------------------------------------------------------
' GET USER INPUT FOR METADATA TAB NAME 'What the function does
Dim n As Integer
n = Worksheets(VBAurlHelper2).Range("A6").Characters.Count
UserDefinedMetadataTabName = Worksheets(VBAurlHelper2).Range("A6").Value

If n <= 2 Then
mymetadataInputValue = Application.InputBox("Please Enter the tab name for your Metadata") 'Ask user to input metadata sheet name

URLhelper.Range("A6").Value = mymetadataInputValue 'print input value to a cell on a specific worksheet

Set metadataWB = myworkBK.Worksheets(mymetadataInputValue) 'Set metadata tab name as variable

Else

'URLhelper.Range("A6").Value = mymetadataInputValue 'print input value to a cell on a specific worksheet
Set metadataWB = myworkBK.Worksheets(UserDefinedMetadataTabName) 'Set metadata tab name as variable

MsgBox ("Metadata Worksheet Already Defined, Continue to use the worksheet named --> " & UserDefinedMetadataTabName & " <-- ?")
End If

'------------------------------------------------------------------------------------------------------------
'<**************************************** END *************************************************************************** **************************************************


'


'
'





'`````````````````````````````````````````````````````````````````````````` ````````````````````````````
'----------------------------- TIME BREAK NOTIFICATION 01 of XX --------------------------------------->

Application.StatusBar = "01/06 - Setting Variables - Why does Waldo wear stripes?"
Application.Wait (Now + TimeValue("00:00:1"))

'----------------------------- TIME BREAK NOTIFICATION END ------------------------------------------->
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````





On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
MsgBox "The sheet named ''" & mySheetName & "'' DOES exist in this workbook and will be cleared"

ThisWorkbook.Worksheets(LatestURLChanges).Activate 'Selects worksheet
ActiveSheet.UsedRange.Delete 'deletes the used range of cells to clear the sheet
Range("a1").Select


Else
Err.Clear
Worksheets.Add.Name = mySheetName 'Creates a new tab named by the variable mySheetName (LatestURLChanges)
MsgBox "The sheet named ''" & mySheetName & "'' did not exist in this workbook but it has been created now."
'move more critical processes to setup like ADDING A BUTTON here as well.

End If



Set FinalURL = m_wbBook.Worksheets(mySheetName)
'Adding color to the final tab
Sheets(LatestURLChanges).Select
With ActiveWorkbook.Sheets(mySheetName).Tab
.Color = 5287936
.TintAndShade = 0
End With
'
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````
'----------------------------- TIME BREAK NOTIFICATION 02 of XX --------------------------------------->

Application.StatusBar = "02/06 - Checking For Required Sheets ----- ANSWER ------> Because he doesn’t want to be spotted."
Application.Wait (Now + TimeValue("00:00:1"))

'----------------------------- TIME BREAK NOTIFICATION END -------------------------------------------->
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````




TotalRange = metadataWB.Cells(Rows.Count, 1).End(xlUp).Row


'Search the array set below - A1:C-last used cell
Set m_rnCheck = metadataWB.Range("A1:C" & TotalRange)


'---------------------------------------------------------------------
'<----------------------- START BLOCK #01 ------------------------->
'---------------------------------------------------------------------
' copy and paste all page numbers and names over to FINAL URL LIST worksheet, and format table


metadataWB.Activate


textToSearchFor = "site page:" 'set value to look for as varaible

metadataWB.Activate
Range("C2").Select 'Selects top of the worksheet

With m_rnCheck 'sets range to DO/LOOP procedure on
Set m_rnFind = .Find(What:=textToSearchFor, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart)
If Not m_rnFind Is Nothing Then
m_stAddress = m_rnFind.Address
Do
Cells.Find(What:=textToSearchFor, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Copy 'Select the found cell and offset select the adjacent page title


FinalURL.Select 'switch worksheets to final url list

Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'find the last row of data in the worksheet, and paste values below

metadataWB.Activate 'Switch worksheets to metadata

ActiveCell.Offset(2, 0).Select 'Step down 2 rows from present location.
Set m_rnFind = .FindNext(m_rnFind)
Loop While Not m_rnFind Is Nothing And m_rnFind.Address <> m_stAddress
End If
End With

'`````````````````````````````````````````````````````````````````````````` ````````````````````````````
'----------------------------- TIME BREAK NOTIFICATION 03 of XX --------------------------------------->

Application.StatusBar = "03/06 - Finished Gathering All Page #'s and Name(s) ----- Question ------> What’s green and has wheels?"
Application.Wait (Now + TimeValue("00:00:1"))

'----------------------------- TIME BREAK NOTIFICATION END -------------------------------------------->
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'------------------------------------------------------------------------------------------------------------------------------------------------
'<------------------------------------------------------------- START BLOCK #0 ---------------------------------------------------------------
'
' DE-DUPE
'
'DESCRIPTION: De-dupe Page Name and Page Numbers
'-------------------------------------------------------------------------------------------------------------------------------------------------
'
'
FinalURL.Activate
TotalRange = FinalURL.Cells(Rows.Count, 1).End(xlUp).Row
Set TotalRange1 = FinalURL.Range("A1:B" & TotalRange)
'ISSUE #01 solution
'trim cells prior to dedupe
Dim Rng2 As Range
Set Rng2 = TotalRange1
For Each cell In Rng2
cell.Value = Trim(cell)
Next cell
'END of trim cycle

TotalRange = FinalURL.Cells(Rows.Count, 1).End(xlUp).Row
Set TotalRange1 = FinalURL.Range("A1:B" & TotalRange)

ActiveSheet.Range("A1:B" & TotalRange).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes 'Remove duplicates, with page header
Range("a1").Select 'Clear selection

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''
' End
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'------------------------------------------------------------------------------------------------------------------------------------------------
'<------------------------------------------------------------- START BLOCK #0 ---------------------------------------------------------------
'
' GET ALL URLS
'
'DESCRIPTION: Copy and paste all page URLs over to FINAL URL LIST worksheet, and format as a table
'-------------------------------------------------------------------------------------------------------------------------------------------------
'
'


metadataWB.Activate
Range("C1").Select



' Set m_rnCheck = metadataWB.Range("A1:C" & TotalRange2) 'Set search array from A1 to C-end of used cells

'
'---------------------------------------------------------------------
'<----------------------- START BLOCK #02a ------------------------->
'---------------------------------------------------------------------
'copy and paste all page URLs over to FINAL URL LIST worksheet, and format as a table
'
'


'`````````````````````````````````````````````````````````````````````````` ````````````````````````````
'----------------------------- TIME BREAK NOTIFICATION 04 of XX --------------------------------------->

Application.StatusBar = "04/06 - Getting Page URLs -------- QUESTION ------ Why do scuba divers jump backwards out of the boat?"
Application.Wait (Now + TimeValue("00:00:1"))

'----------------------------- TIME BREAK NOTIFICATION END ------------------------------------------->
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````

'set value to look for
textToSearchFor2 = "Page URL"

'Retrieve all columns that contain an X. If there is at least one, begin the DO/WHILE loop.
With m_rnCheck
Set m_rnFind = .Find(What:=textToSearchFor2, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart)
If Not m_rnFind Is Nothing Then
m_stAddress = m_rnFind.Address

'Hide the column, and then find the next X.
Do
Cells.Find(What:=textToSearchFor2, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Copy


FinalURL.Activate 'switch worksheets to final url list
Range("C1").Select
'find the last row of data in the worksheet, and paste below
Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)

metadataWB.Activate
' Step down 2 rows from present location.
ActiveCell.Offset(2, 0).Select
Set m_rnFind = .FindNext(m_rnFind)
Loop While Not m_rnFind Is Nothing And m_rnFind.Address <> m_stAddress
End If
End With




'
'---------------------------------------------------------------------
'<----------------------- START BLOCK #03 -------------------------->
'---------------------------------------------------------------------
'insert column with date and time stamp, then add table headers, and remove column C
'
'




'`````````````````````````````````````````````````````````````````````````` ````````````````````````````
'----------------------------- TIME BREAK NOTIFICATION 05 of XX --------------------------------------->

Application.StatusBar = "05/06 - Formating Table -------- QUESTION ------ Because if they jumped forward, they’d still be in the boat."
Application.Wait (Now + TimeValue("00:00:1"))

'----------------------------- TIME BREAK NOTIFICATION END ------------------------------------------->
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````


'Select Final URL LSIT worksheet cell A1
FinalURL.Activate
Range("A1").Select

'Delete column "Page URL:"
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

'add new column with date and time stamp, then add headers to the sheet
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
With Selection
.Value = Now
.NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
End With
Range("B1").Select
ActiveCell.FormulaR1C1 = "Page #"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Page Name"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Page URL"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Notes"
Columns("A:E").Select
Selection.Columns.AutoFit










'`````````````````````````````````````````````````````````````````````````` ````````````````````````````
'----------------------------- TIME BREAK NOTIFICATION 06 of 06 --------------------------------------->

Application.StatusBar = "06/06 - !! DONE PROCESSING!!"
Application.Wait (Now + TimeValue("00:00:1"))

'----------------------------- TIME BREAK NOTIFICATION END ------------------------------------------->
'`````````````````````````````````````````````````````````````````````````` ````````````````````````````


'Clear Status bar message
Application.StatusBar = False


'Adding color to the final tab
Sheets(LatestURLChanges).Select
With ActiveWorkbook.Sheets(VBAurlHelper2).Tab
.Color = RGB(0, 26, 87)
.TintAndShade = 0
End With
'
ThisWorkbook.Worksheets(LatestURLChanges).Activate 'Selects worksheet
'
' SPEEDY CODE END
Application.ScreenUpdating = True 'disables screen updating
'Application.DisplayStatusBar = True 're-enableds status bar messages
Application.EnableEvents = True 'disables trigger events
'ActiveSheet.DisplayPageBreaks = True '
Application.Calculation = xlCalculationAutomatic 'disables auto calculations
'
ThisWorkbook.Worksheets(LatestURLChanges).Activate
ThisWorkbook.Worksheets(LatestURLChanges).UsedRange.Select
ActiveWindow.Zoom = True
Range("A1").Select


MsgBox "Done!!", vbInformation, "URL Wizard - Getting URLs - Intouch SEO"
'
End Sub

[paulked]

A common mistake when declaring variables is assuming that variables before a comma will be declared the same as the one after it. Wrong! Example:



Dim m_wbBook, myworkBK As Workbook


This declares m_wbBook as Variant and only myworkBK as Workbook. To be correct it needs to be



Dim m_wbBook As Workbook, myworkBK As Workbook


You also set both of them to the same workbook without changing any of them in the rest of the code, you don't need both of them.

Although this won't impact on the speed, it could throw you off course in future.

You haven't declared TotalRange As Long, TotalRange1 As Range, Cell as Range - again no impact on speed but IMO if you are going to declare the variables then declare them all.

Application.Wait - I'm guessing you are using this so that the status bar updates with your text. Replacing these with DoEvents will save a whole 6 seconds!

Your code is slow because of the selecting, copying, activating, selecting and pasting.



'Slow
Sheet1.Select
Range("A1").Copy
Sheet2.Select
Range("A1").PasteSpecial

'Faster
Sheet1.Range("A1").Copy Sheet2.Range("A1")

'Fastest
Sheet2.Range("A1") = Sheet1.Range("A1")


In your loops use variables to keep track of where you are rather than calculating the last row every time - just bad practice if you've only got a couple of lines but crippling if you've got thousands!

There are many sites out there which will show you faster ways of coding. A quick search came up with this (https://www.ozgrid.com/VBA/SpeedingUpVBACode.htm) one.

[JETTLIFE]

Thanks for the feedback paulked - I knew at one point i was using two variables assigned to the same value but no idea how many duplicates i had, and i see now that it totally confused me a few times while creating this. I will try some of things you suggested and what is on that link to see if i can figure it out. Thank you for some direction here! :)

[paulked]

What do your functions FindAltImageHELP and FindAltImage do?

As soon as you turn calculation back on in the code they buzz round like a nest of hornets. That is what's taking the time!

[JETTLIFE]

LOL :banghead::banghead: I have been thinking the same thing about it being so crazy - never thought of it like a nest of hornets, but it is so chaotic in when it jumps back and forth between modules.... but I dont know how to isolate the dam thing. I did not create that, it was from someone who worked at my job a while ago i guess, idk who it was. But it is so volatile its nuts. So what this workbooks purpose is - to feed into an internal process within my company to create metadata for pharma websites that must be reviewed and approved by a mess of people, so we export as PDF. Including all images ALT text (https://www.google.com/search?q=image+ALT+text).... this vba function i believe auto shows match or no match on the metadata tab, if you unhide all columns, you will see a match side of functions that we can paste a ScreamingFrog (https://www.screamingfrog.co.uk/seo-spider/) crawl of thee dev site, the staging site, then the production site into the tabs that have a title starting with "Screaming Frog..." and it will auto indicate which is correctly implemented by Development, and which we need fixed before moving to next stage.

You have any suggestions on how to make this thing maybe only trigger when selected? Can I measure how much time it does add to the VBA? I feel like what you mentioned prior is what I was looking for, just don't know how to do it per say yet - and have no incentive to make faster as no one cares, just super impressed it works in general. LOL, i knew there had to be a more efficient way of doing things. I tried looking into your suggestion of the "DoEvents" which led me down a rabbit hole of setting up a progress bar :) which i did not get to work successfully. Your assumption is correct in that the purpose is to show indication to end user that it is still working. I already know of a handful of peeps on my team that will be hesitant to change, let alone something that sits and freezes there excel.. Especially because most workbooks do have 2,000+ rows... :think:

Thanks for your time looking at this at all, you gave me some really great things to look into, i am just so new to this VBA world it is still a big learning curve i am overcoming. Thanks though for all your help!! :yes

[paulked]

I haven't done anything special here, just spent 10mins sifting through whilst having coffee (my dear wife has me on 'Jobs round the house' today!)

I've removed the module with the functions in, they didn't seem to make any difference, so I'm assuming they were used when the frog was introduced and, once used, have done their job!

Put a userform progress in, not as quick as status bar but quick enough for this application, it's more visible to the user!

Removed the sheet selections during copy/paste.

It now runs in 17 seconds rather than 86!

If I get a bit more time then I'll have another look.

I couldn't upload the file here for some reason, I tried making it smaller by deleting the hidden sheets but it still wouldn't have it. Link to file here (https://1drv.ms/x/s!Av8oW8_xzD3EvQZ2mbfFIJ4KATHg?e=ye4BAh)

[paulked]

Had an extended lunch break and revised the code to do it all in under a second!



Sub GetURLs002()
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
'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
'Set sheet names
Set shDest = Sheets("URL List 1")
'Put source int array
ar = shMeta.UsedRange
'Loop through data and write to new array ignoring formula errors on data page!
For i = LBound(ar, 1) 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("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("C1:C" & 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 = vbRed
shDest.Range("B1").CurrentRegion.Copy .Range("A1")
.Columns("A:D").Columns.AutoFit
End With
Sheets("URL wizard").Activate
End Sub

[JETTLIFE]

paulked you are amazing - Thank you so much for your help with this, you are a true VBA genius - i knew there was a way to optimize code as it seemed very long and clumsy, but holy s*** i had no clue it could be this short and optimized to execute so freaking fast! I am blown away how freaking fast it is, still dynamic, and works exactly how i needed. I appreciate your efforts and time and sharing your skills to help this guy out!

[paulked]

The beauty of arrays, and it's all down to the clever people here at VBA Express who are teaching me :yes

[JETTLIFE]

:clap: Well you certainly are teaching me some awesome stuff here about VBA best practices and efficiencies as well, and i will be sure to put my time in contributing to other peeps questions if i can be of help.

Quick question - i just noticed that it doesn't add the date and time stamp in A1 and instead adds to sheet name. I am having trouble adding that value back into your code. The purposes of this is for the 2nd part of why i need the list of Page numbers, names, and URLs is to run the second VBA i created which compares the two lists and identifies what pages have been deleted or added between the two lists (I added it below for reference). The VBA i created to compare the list is dependant on the sheets that i am comparing having the URLs be in column D. While i know i could just edit my vba to compare a diff column, i also use that date and time stamp in the header of the worksheet "Latest URL Changes". So my question is, how do i add that date and time stamp back to A1 without messing up your amazing efficiencies? :think:

Use case explanation: We have a website with existing metadata, client wants to add new webpages, or consolidate existing pages into 1 new webpage. We then need a list of these URL changes to pass to other teams, and it is critical to be sure they have the most "up-to-date" urls for PPC and Display ads. The URL Wizard tab - has button to trigger this process in the existing workbook. However -- here is an updated workbook (https://cloud.jettlifetech.com/excel-vba/SampleURLWizardKed.xlsm) with your latest VBA added for sample data. In the module named "URLWizardV02" has 3 VBA routines, 1) is the first time setup of URL Wizard sheet with two buttons and assigns them to a macro. 2) this is one of the button macros, and it is using your very fast, and efficient routine to find all page numbers, names, and urls. 3) this is the other button macro that compares two tabs that a user is prompted to enter what tabs they want to compare.



Sub GetTheLatestURLChanges003()
' MACRO BLOCK START
'Short Summary:
'This macro will check the workbook for a worksheet titled "Latest URL Changes" and if it exist, it will clear the sheet
'if the worksheet does not exist, it will then be created.
'Purpose: To compare two list of content and identify exactly what is different between the two list (whats new, whats been deleted)
'How does it work?
'Step 1: Select button to trigger on URL Wizard worksheet
'Step 2: The VBA will prompt you to enter the worksheet name of the old URL list
'Step 3: The VBA will prompt you to enter the worksheet name of the NEW URL list
'Step 4: Then it will check for a worksheet named "Latest URL Changes"
'If the worksheet exist, it will clear it
'If it does not exist - it will create it.
'Step 5: Then it will copy both sheets into the worksheet called "Compared List"
'Step 6: Compares both list and outputs what has been REMOVED in column K
'Step 7: Compares both list and outputs what has been ADDED in column L
'Step 8: Delete columns A-F
'Speed up code processing time
Application.ScreenUpdating = False
'Application.DisplayStatusBar = True
Application.EnableEvents = False
'Application.ScreenUpdating = True
'ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Dim newSheetName As String
Dim VBAurlHelper1 As String
Dim checkSheetName As String
Dim sheet1, sheet2 As Worksheet
Dim mymetadataInputValue, mymetadataInputValue2 As String
Dim wrkShet1 As Worksheet
'Setting variable values
'VBAurlHelper1 = "URL Wizard"
newSheetName = "Latest URL Changes"
'TIME BREAK NOTIFICATION 01 of XX
Application.StatusBar = "01/06 - Setting Variables"
Application.Wait (Now + TimeValue("00:00:01"))
'TIME BREAK NOTIFICATION END
On Error Resume Next
checkSheetName = Worksheets(newSheetName).Name
If checkSheetName = "" Then
Worksheets.Add.Name = newSheetName
MsgBox "The sheet named ''" & newSheetName & _
"'' does not exist in this workbook but it has been created now.", _
vbInformation, "Intouch SEO Automation for Excel"
Else
MsgBox "The sheet named ''" & newSheetName & _
"''exist in this workbook.", vbInformation, "Intouch SEO Automation for Excel"
Worksheets(newSheetName).Activate
ActiveSheet.UsedRange.Delete 'deletes the used range of cells to clear the sheet
Range("a1").Select
End If
Set wrkShet1 = ActiveSheet
mymetadataInputValue = Application.InputBox("Please enter the tab name for the old list of URLs you want to compare to.", "Intouch SEO Automation for Excel") 'Ask user to input metadata sheet name
ThisWorkbook.Worksheets(VBAurlHelper1).Range("A7").Value = mymetadataInputValue 'print input value to a cell on a specific worksheet
Set sheet1 = ThisWorkbook.Worksheets(mymetadataInputValue) 'Set metadata tab name as variable
mymetadataInputValue2 = Application.InputBox("Please enter the tab name for the newest list of URLs you want to compare to.", "Intouch SEO Automation for Excel") 'Ask user to input metadata sheet name
ThisWorkbook.Worksheets(VBAurlHelper1).Range("A8").Value = mymetadataInputValue2 'print input value to a cell on a specific worksheet
Set sheet2 = ThisWorkbook.Worksheets(mymetadataInputValue2) 'Set metadata tab name as variable
sheet1.Activate
sheet1.UsedRange.Select 'auto select all cells with data
Selection.Copy
ThisWorkbook.Worksheets(newSheetName).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
'START --> formatting the compared results output
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("F1:J1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K1:L1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(0, 26, 87) '5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.Bold = True
.Size = 15
End With
Range("K2").Select
ActiveCell.FormulaR1C1 = "Deleted URLs"
Range("L2").Select
ActiveCell.FormulaR1C1 = "New URLs"
Range("L1").Activate
Range("K1:L1").Select
ActiveCell.FormulaR1C1 = "URL List Comparison Results"
'END --> formatting the compared results output
Sheets(mymetadataInputValue2).Select
sheet2.UsedRange.Select 'Dynamically selecting the used range
Selection.Copy
ThisWorkbook.Worksheets(newSheetName).Select
Range("F2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("F2").Select
Selection.Copy
Range("H1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
'Add LAST UPDATED tag to row 1
Range("G1").Select
ActiveCell.FormulaR1C1 = "Last Updated:"
Range("G1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Bold = True
'TIME BREAK NOTIFICATION 01 of XX
Application.StatusBar = "02/03 - Setting Formats"
Application.Wait (Now + TimeValue("00:00:01"))

'TIME BREAK NOTIFICATION END
'LIST COMPARE - START - Removed URLs
Dim v1, v2, v3(), i As Long, j As Long
v1 = Range("D3", Range("D" & Rows.Count).End(xlUp)).Value
v2 = Range("I3", Range("I" & Rows.Count).End(xlUp)).Value
ReDim v3(1 To UBound(v1, 1))
For i = LBound(v1) To UBound(v1)
If IsError(Application.Match(v1(i, 1), v2, 0)) Then
j = j + 1
v3(j) = v1(i, 1)
End If
Next i
Range("K3").Resize(j) = Application.Transpose(v3) 'output the differences in this range
'Check for New URLs and list them to the side
Dim v1a, v2a, v3a(), i2 As Long, j2 As Long
v1a = Range("I3", Range("I" & Rows.Count).End(xlUp)).Value
v2a = Range("D3", Range("D" & Rows.Count).End(xlUp)).Value
ReDim v3a(1 To UBound(v1a, 1))
For i2 = LBound(v1a) To UBound(v1a)
If IsError(Application.Match(v1a(i2, 1), v2a, 0)) Then
j2 = j2 + 1
v3a(j2) = v1a(i2, 1)
End If
Next i2
Range("L3").Resize(j2) = Application.Transpose(v3a) 'output the differences in this range
'LIST COMPARE - END - Removed URLs
Range("K2").Select
ActiveCell.FormulaR1C1 = "Deleted URLs"
Range("L2").Select
ActiveCell.FormulaR1C1 = "New URLs"
Range("K1").Activate
Range("K1:L1").Select
ActiveCell.FormulaR1C1 = "URL List Comparison Results"
Columns("A:F").Select
Selection.Delete Shift:=xlToLeft
Range("A2:F2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Size = 12
Selection.Font.Size = 14
Range("B1").Select
Worksheets(newSheetName).Columns("A:F").AutoFit
'TIME BREAK NOTIFICATION 01 of XX
Application.StatusBar = "03/03 -- DONE"
Application.Wait (Now + TimeValue("00:00:01"))
'TIME BREAK NOTIFICATION END
'Speed up code processing time
Application.ScreenUpdating = True
Application.StatusBar = False 'Clears status bar
'Application.DisplayStatusBar = False
Application.EnableEvents = True
'ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.Worksheets(newSheetName).Activate
ThisWorkbook.Worksheets(newSheetName).UsedRange.Select
ActiveWindow.Zoom = True
Range("A1").Select
MsgBox "Done!!", vbInformation, "URL Wizard - List Compare - Intouch SEO"
End Sub

[paulked]

Sorry, I put it to a new sheet thinking it was to be exported. This will put it in A1 (changes in red):



Sub GetURLs002()
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
'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
'Set sheet names
Set shDest = Sheets("URL List 1")
'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("C1:C" & 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 = vbRed
shDest.Range("A1").CurrentRegion.Copy .Range("A1")
.Columns("A:E").Columns.AutoFit
End With
Sheets("URL wizard").Activate
End Sub


If you don't want the new sheet created, delete the code from 'Add a new sheet... to End Sub (URL wizard should still be the active sheet)

[paulked]

Be aware!!

You can't have more than one copy of a routine with the same name in a project, even if they are in different modules.

[SamT]

@ Jett and Paul,

Only Standard Modules can't use the same Names, because they are all compiled as a single "DLL." The purpose of Standard Modules is to make Programmers' jobs easier by providing a way to better organize their code.

Class Modules can use the same Procedure names, because Class Modules are only visible to external code as Instantiated Objects.

ThisWorkbook and Worksheet Code pages can also use the same Procedure names, because they are Instantiated Class Modules and their Code Pages are really addendums to their Class code. The ThisWorkbook Code Page is that particular Workbook's Class "Addendum."

UserForms are also Classes and multiple Forms can use the same names

You can see all of any Class Objects Properties, Methods, Events, and, Public Variables and Constants by pressing F2 while viewing that Code Page

[paulked]

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.

[JETTLIFE]

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!



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

[paulked]

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?

[paulked]

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:

26609

[JETTLIFE]

Interested for sure, and to answer your question - yes. Thanks again for all your help here sir!

[paulked]

In that case mymetadataInputValue2 = "URL List 1", no need for user input :)

[JETTLIFE]

: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 (dainedvorak@gmail.com)if interested in that $ tip or to chat offline - thank you so much again! I personally am shocked how kind this community is here.

[paulked]

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

[snb]

@Paulk

Why not simply Data Validation ?

[paulked]

It is selected during macro run (it was through an input box). It could, of course, be selected 1st!

[JETTLIFE]

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/1nsnee-xs4dP1f67e0gDACPPB7aTkDLD0/view?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-wKMUxvSftPuUI0GSTZdRLriA_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

[paulked]

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:



ar = shMeta.UsedRange.SpecialCells(xlCellTypeVisible)


I haven't tested it, but it could do the trick!!

[JETTLIFE]

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..

[paulked]

It worked ok for me, see attached file (and yes, it is 02:30!).

File won't upload so here's a link (https://1drv.ms/x/s!Av8oW8_xzD3E63zC3Rv_UwM2i7fB?e=5aa1dg)

snb has a great site http://www.snb-vba.eu/VBA_Arrays_en.html

[JETTLIFE]

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

[JETTLIFE]

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:

[paulked]

I've seen the error! I'll have a look into it.

[paulked]

Okay, think I've got it. Add a 'Helper' sheet and name it Help (you can hide it if you wish) then replace



ar = shMeta.UsedRange.SpecialCells(xlCellTypeVisible)

with



Sheets("Help").Cells.ClearContents
shMeta.UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets("Help").Range("A1").PasteSpecial xlPasteValues
ar = Sheets("Help").UsedRange


Hope that works for you, worked for me hiding either of those groups of rows you mentioned and both together.

[JETTLIFE]

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 (https://drive.google.com/open?id=1AIMB9FbWmQNuTKvEnNOLMEf94oejUdKn) - 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!

[paulked]

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):


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!

[JETTLIFE]

paulked - this is epic, and works perfect! :bow: :clap: :bow: - you are a god with this VBA wizardry - as always, i really appreciate the help!

[paulked]

Glad it all worked.

Take care and stay safe :thumb