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