3 Attachment(s)
Need help copying cells from one sheet to another..
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 -> Attachment 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.
Code:
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
Attachment 26359Attachment 26360
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.
Code:
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!
1 Attachment(s)
SamT Thank you so much for your help, but im having issues...!
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...+workbook.xlsm
Here is a highly compressed one with all other functions removed and stripped bare to send through this forums attachment manager. --> Attachment 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!
I figured it out, but its very slow and cumbersome, any one be able to help optimize?
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...URLWizard.xlsm
Code:
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