EXCEL VBA MACRO EDIT - excel

I need this macro to generate 2 (or more) data columns from 2 (or more) cell references. Currently it only does one data series from one cell reference. The script generates a table and updates the table with a new data entry on each second, then updates a chart using the table data. The cell value is changing in real-time.
This should be a simple fix but I can't figure out the code. I'm out of my league. Any help would be awesome. Maybe somebody can refactor this or at least give me some hints as to what I should do.
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Tickers"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").value = "Time"
.Range("B1").value = "Value"
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:B1"), _
xllistobjecthasheaders:=xlYes)
lstObject.name = sTableName
.Range("A2").NumberFormat = "h:mm:ss"
.columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).row
End If
If lRow = 0 Then
lRow = .Range("A" & .rows.Count).End(xlUp).offset(1, 0).row
End If
.Range("A" & lRow).value = CDate(Now)
.Range("B" & lRow).value = Worksheets(sSourceWSName).Range("M4").value
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
This is the snippet from "ThisWorkbook"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Stop workbook refreshing
Call Chart_Stop
End Sub

I hope this helps.
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Tickers"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.Name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").Value = "Time"
.Range("B1").Value = "Value1"
'**** I added C! and changed "Value" to "Value1" and "Value2"
.Range("C1").Value = "Value2"
'**** I increased the range of the chart below to C1
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:C1"), _
xllistobjecthasheaders:=xlYes)
lstObject.Name = sTableName
.Range("A2").NumberFormat = "h:mm:ss"
.Columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Public Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).Row
End If
If lRow = 0 Then
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End If
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = 4
.Range("C" & lRow).Value = 5
'******I used the two line above to test results, uncomment the line below and feel free to change M5 to any other renge location workd best for you
' .Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("M4").Value
' .Range("C" & lRow).Value = Worksheets(sSourceWSName).Range("M5").Value
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub

Related

FindNext within a For Each loop

I need to know how to get FindNext working in my code. It finds the photo inserts it into the column where the code matches, however it does not find the next code in the worksheet, so it keeps overwriting the photos in the first find. Where I have put the comment find next photo1 is where it should be going?
Private Sub cmdInsertPhoto1_Click()
'insert the photo1 from the folder into each worksheet
Dim ws As Worksheet
Dim fso As FileSystemObject
Dim folder As folder
Dim rng As Range, cell As Range
Dim strFile As String
Dim imgFile As String
Dim localFilename As String
Dim pic As Picture
Dim findit As String
Dim finditfirst As String
Application.ScreenUpdating = True
'delete the two sheets if they still exist
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "PDFPrint" Then
Application.DisplayAlerts = False
Sheets("PDFPrint").Delete
Application.DisplayAlerts = True
End If
Next
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "DataSheet" Then
Application.DisplayAlerts = False
Sheets("DataSheet").Delete
Application.DisplayAlerts = True
End If
Next
Set fso = New FileSystemObject
Set folder = fso.GetFolder(ActiveWorkbook.Path & "\Photos1\")
'Loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
ws.Select
Set rng = Range("A:A")
For Each cell In rng
If cell = "CG Code" Then
'find the next adjacent cell value of CG Code
strFile = cell.Offset(0, 1).Value 'the cg code value
imgFile = strFile & ".png" 'the png imgFile name
localFilename = folder & "\" & imgFile 'the full location
'find Photo1 cell and select the adjacent cell to insert the image
findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
ActiveCell.EntireRow.RowHeight = 200 'max row height is 409.5
Set pic = ws.Pictures.Insert(localFilename)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 200
.ShapeRange.Height = ActiveCell.MergeArea.Height
.ShapeRange.Top = ActiveCell.MergeArea.Top
.ShapeRange.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With
'find next photo1
End If
'delete photo after insert
'Kill localFilename
Next cell
Next ws
Application.ScreenUpdating = True
' let user know its been completed
MsgBox ("Worksheets created")
End Sub
Scan column A for both "Photo1" and "CG Code" values to build collections for each. Then iterate the collections to insert the images.
Option Explicit
Private Sub cmdInsertPhoto1_Click()
Dim wb As Workbook, ws As Worksheet, fso As FileSystemObject
Dim rng As Range, cell As Range, pic As Picture
Dim folder As String, imgFile As String
Dim lastrow As Long, i As Long, n As Long
Dim colImages As Collection, colPhotos As Collection
Set colImages = New Collection
Set colPhotos = New Collection
Set fso = New FileSystemObject
Set wb = ActiveWorkbook
folder = wb.Path & "\Photos1\"
Application.ScreenUpdating = False
For Each ws In wb.Sheets
'delete the two sheets if they still exist
If ws.Name = "PDFPrint" Or ws.Name = "DataSheet" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Else
' find images and photos
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For Each cell In ws.Range("A1:A" & lastrow)
If cell = "CG Code" Then
imgFile = folder & cell.Offset(0, 1) & ".png"
' check exists
If fso.FileExists(imgFile) Then
colImages.Add imgFile
Else
MsgBox imgFile & " not found", vbCritical
Exit Sub
End If
ElseIf cell = "Photo1" Then
colPhotos.Add "'" & ws.Name & "'!" & cell.Offset(0, 1).Address
End If
Next
End If
Next
' copy images to sheets
For i = 1 To colImages.Count
imgFile = colImages(i)
If i <= colPhotos.Count Then
Set cell = Range(colPhotos(i))
cell.RowHeight = 200 'max row height is 409.5
Set pic = cell.Parent.Pictures.Insert(imgFile) ' ws
With pic.ShapeRange
.LockAspectRatio = msoFalse
.Width = 200
.Height = cell.MergeArea.Height
.Top = cell.MergeArea.Top
.Left = cell.MergeArea.Left
pic.Placement = xlMoveAndSize
End With
n = n + 1
Else
MsgBox "No location for " & imgFile, vbCritical, i
Exit Sub
End If
Next
Application.ScreenUpdating = True
' let user know its been completed
MsgBox n & " images inserted ", vbInformation
End Sub

Having error 400 when creating several textBox when pressing a button

I have a workbook with 2 sheets (one to place the data and another for options).
The one with the data it has some buttons (at row 1), some textBox and DropBox (at row 2) and at row 3 are the headers of the table with all the data below.
The sheet with the options for the moment has only one button to recreate the menu (the TextBox and DropBox at row 2 in the data sheet)
However when pressing the button to run the macro it gives error 400 with no description and a red x signal. Sometimes it gives error when re-creating and first textBox, sometimes the second or third as well (never the fourth or the fifth).
Why does such 400 error happen ? What causing it ?
When trying debug the code i placed some Debug.Print in some places and after running 3 times (after clicking in button 3 times this is the output in the immediate window.
-----------Running createMenu-----------
TextBox5 DIM done
TextBox5 Set done
TextBox6 Delete
-----------Running createMenu-----------
TextBox5 Delete
TextBox5 DIM done
TextBox5 Set done
TextBox6 DIM done
TextBox6 Set done
TextBox7 Delete
-----------Running createMenu-----------
TextBox5 Delete
The code below (the one to recreate the menus) is placed in the data worksheet.
Sub createMenu()
Debug.Print "-----------Running createMenu-----------"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
.Range("A2").NumberFormat = "0"
.Range("B2").NumberFormat = "dd-mm-yyyy"
.Range("C2:D2").Merge
.Range("C2:D2").NumberFormat = "hh:mm:ss"
Call newTextBox(.Range("E2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("F2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("G2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("H2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("I2"))
Call newDropBox(.Range("J2"), "=Opções!A1:A14")
Call newDropBox(.Range("K2"), "=Opções!B1:B2")
.Range("A2:N2").HorizontalAlignment = xlCenter
End With
End Sub
Sub newDropBox(t As Range, list As String)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws.Range(t.Address).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=list
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub newTextBox(t As Range)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
Dim OLEObj As OLEObjects
If .OLEObjects.Count > 0 Then
Dim x As Integer
For x = 1 To .OLEObjects.Count
If .OLEObjects(x).Name = "TextBox" & t.Column Then
.OLEObjects(x).Delete
Debug.Print "TextBox" & t.Column & " Delete"
End If
Next x
End If
Dim myTextBox As OLEObject
Debug.Print "TextBox" & t.Column; " DIM done"
Set myTextBox = .OLEObjects.Add("Forms.TextBox.1")
Debug.Print "TextBox" & t.Column; " Set done"
With myTextBox
.Name = "TextBox" & t.Column
.LinkedCell = t.Address
.Left = t.Cells.Left
.Top = t.Cells.Top
.Width = t.Cells.Width
.Height = t.Cells.Height
.Object.BackColor = 16777152
.Object.BorderStyle = 1
.Object.BorderColor = 0
End With
End With
End Sub
So i find out the reason ...
So when i am doing the for loop he started by finding (lets say 2 OLEObjects).
If the in the first cycle of the loop the wanted object is found he delete one of the objects making it the total OLEObjects count to less 1.
There for when cycling to the second OLEObjects he will not find it, and throw such 400 error.
So the fix i done was exit the loop when the target OLEObjects is found.
Sub newTextBox(t As Range)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
Dim OLEObj As OLEObjects
If .OLEObjects.Count > 0 Then
Dim x As Integer
For x = 1 To .OLEObjects.Count
If .OLEObjects(x).Name = "TextBox" & t.Column Then
.OLEObjects(x).Delete
Exit For
End If
Next x
End If
Dim myTextBox As OLEObject
Set myTextBox = .OLEObjects.Add("Forms.TextBox.1")
With myTextBox
.Name = "TextBox" & t.Column
.LinkedCell = t.Address
.Left = t.Cells.Left
.Top = t.Cells.Top
.Width = t.Cells.Width
.Height = t.Cells.Height
.Object.BackColor = 16777152
.Object.BorderStyle = 1
.Object.BorderColor = 0
End With
End With
End Sub

look up cell value in range and if not found delete row. taking 120+ minutes to run

I have the following code but due to the fact that the sheet I'm processing has 190,000 rows of data it is taking 120+ minutes to process all of it:
Start With
Sub Import_Data()
Start_Import "WIR-Deploy"
End Sub
Then this is where I set everything:
Option Explicit
Public WB1 As Workbook
Public WS1 As Worksheet
Public WS2 As Worksheet
Public updateSuccess As Boolean
Sub Start_Import(strApp As String)
Dim WS3 As Worksheet
Dim importFile As String
Set WB1 = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WS1 = WB1.Sheets("Master Sheet")
If strApp = "WIR-Deploy" Then
Set WS2 = WB1.Sheets("RawWhoIsReady-Deploy#8Jul")
importFile = "H:\99 - Temp\WhoIsReady-Deploy.csv"
Application.StatusBar = "'Who is ready - Deploy' data Import now runnning..."
Else
MsgBox "Not Coded Yet"
Exit Sub
End If
If strApp = "WIR-Deploy" Then
ImportData strApp, importFile
Else
MsgBox "Not Coded Yet"
Exit Sub
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub
and then this imports the sheet:
Option Explicit
Sub ImportData(strApp, importFile)
Dim WB2 As Workbook
Dim WS3 As Worksheet
Dim lRow, lCol, ImportRow As Long
Dim rngAsset As Range
Set WB2 = Workbooks.Open(importFile)
If strApp = "WIR-Deploy" Then
WB2.Sheets(1).Copy Before:=WS2
WB2.Close False
Set WS3 = WB1.ActiveSheet
WS3.Columns(1).EntireColumn.Delete
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
With WS3
.Sort.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.Sort.SetRange Range(.Cells(1, 1), .Cells(lRow, lCol))
.Sort.Header = xlYes
.Sort.Apply
End With
For ImportRow = 2 To lRow
Set rngAsset = WS1.Range("A:A").Find(WS3.Cells(ImportRow, 1))
If rngAsset Is Nothing Then
WS3.Rows(ImportRow).EntireRow.Delete
ImportRow = ImportRow - 1
lRow = lRow - 1
End If
Application.StatusBar = "[Deploy Import] " & lRow & " left to process. " & ImportRow & " Retained"
Set rngAsset = Nothing
Next
Else
MsgBox "This has not been coded yet", vbOKOnly + vbCritical
Exit Sub
End If
'WS3.Delete
WB1.RefreshAll
End Sub
Is there anyway I can speed this process up ? A better way to do it? My limited knowledge says that i would struggle to make it any quicker but i'm open to any ideas on making it better
Something like this:
Dim m, rngDel As Range, numDel As Long
'...
numDel = 0
For importrow = lRow To 2 Step -1
'Match is much faster than Find...
m = Application.Match(ws3.Cells(importrow, 1).Value, WS1.Range("A:A"), 0)
If IsError(m) Then
numDel = numDel + 1 '<< count rows added
If rngDel Is Nothing Then
Set rngDel = ws3.Rows(importrow)
Else
Set rngDel = Application.Union(rngDel, ws3.Rows(importrow))
End If
'delete in batches
If numDel > 1000 Then
rngDel.Delete
Set rngDel = Nothing
numDel = 0
End If
End If
'don't update statusbar too often
If importrow Mod 1000 = 0 Then
Application.StatusBar = "On row " & importrow
End If
Next
'delete last batch of rows
If Not rngDel Is Nothing Then rngDel.Delete
You can experiment with deleting rngDel once it gets to a certain size: I recall it can get slower to append new rows once the size gets too large...

VBA Loop through row until blank and variable use

The code below is a web page table scraper that I am using and it works nicely. It currently only opens the hyperlink that is in location 'L4' using .Open "GET", Range("L4"), False
Sub ImportData()
'Objects
Dim htm As Object
Dim Tr As Object
Dim Td As Object
Dim Tab1 As Object
'Create HTMLFile Object
Set HTML_Content = CreateObject("htmlfile")
'Get the WebPage Content to HTMLFile Object
On Error GoTo Error
With CreateObject("msxml2.xmlhttp")
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
.send
HTML_Content.body.innerHTML = .responseText
End With
On Error GoTo Error
'Add New Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "ESTIMATE"
'Set table variables
Column_Num_To_Start = 1
iRow = 2
iCol = Column_Num_To_Start
iTable = 0
'Loop Through Each Table and Download it to Excel in Proper Format
For Each Tab1 In HTML_Content.getElementsByTagName("table")
With HTML_Content.getElementsByTagName("table")(iTable)
For Each Tr In .Rows
For Each Td In Tr.Cells
Sheets(2).Cells(iRow, iCol).Select
Sheets(2).Cells(iRow, iCol) = Td.innerText
iCol = iCol + 1
Next Td
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tr
End With
iTable = iTable + 1
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tab1
'Success
'Loop to find authorised hours string
Dim rng1 As Range
Dim strSearch As String
strSearch = "Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
'Add Value to Sheet1
Sheets(1).Range("E4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("E4").Value = 0
End If
strSearch = "Actual Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("D4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("D4").Value = 0
'Move on to next
End If
strSearch = "Name"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("J4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("J4").Value = "NULL"
End If
'Scrape Description
Dim desc As String
HTML_Content.getElementsByTagName ("div")
desc = HTML_Content.getElementsByTagName("p")(0).innerText
Sheets(1).Range("K4").Value = desc
'Keep Sheet 1 Open
Sheets(1).Activate
'Delete ESTIMATE Sheet
Application.DisplayAlerts = False
Sheets(2).Delete
Application.DisplayAlerts = True
Error:
End Sub
The starting row of the hyperlink is L4, how could I make a loop that cycles through all links located in the L column and runs this script for each hyperlink that is in column L? How would I make a variable to so that Range will know what row is currently being processed?
Could I put my code into something like this:
For Each i In Sheet1.Range("L4:L200")
' code here
Next i
Any help is much appreciated, thank you.
change
Sub ImportData()
...
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
...
into
Sub ImportData(urlToOpen as string)
...
.Open "GET", urlToOpen, False 'Cell that contains hyperlink
...
and add a calling procedure:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i)
Next i
end sub
UPDATE 1
To get data from the procedure you might either send it back into the main procedure or you prepare a place prior to calling the procedure:
either:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i, returnValue)
i.offset(0,1).value = returnValue
Next i
end sub
Sub ImportData(urlToOpen as string, returnValue as string)
...
'returnValue = Data you want to give back
returnValue = DataSource...(I didn't read your code again ;-)
...
or:
Sub CallRangeL_Urls
Dim targetRange as Range
For Each i In Sheet1.Range("L4:L200")
' code here
sheets.add after:=sheets(1)
'set a link on the sheet
Range("A1").value = i
Set targetRange = Range("A3")
call ImportData(i, targetRange)
Next i
end sub
Sub ImportData(urlToOpen as string, target as range)
...
'Save whatever data to the new sheet
target.offset(0,0).value = datavalue1 'Range("A3")
target.offset(1,0).value = datavalue1 'Range("A4")
target.offset(2,0).value = datavalue1 'Range("A5")
...
UPDATE 2
UPDATE 2: single data items (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim Sheet1 As Worksheet
Dim returnValue As String
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
' code here
Debug.Print "url: "; iCell.Value
Call ImportData(iCell.Value, returnValue)
iCell.Offset(0, 1).Value = returnValue
Debug.Print returnValue
Next iCell
End Sub
Sub ImportData(urlToOpen As String, ByRef returnValue As String)
'...
'returnValue = Data you want to give back
returnValue = "This is the data we get back from yourUrl: " & urlToOpen & " - DATA/DATA/DATA" 'DataSource...(I didn't read your code again ;-)
End Sub
Immediate window:
url: www.google.de
This is the data we get back from yourUrl: www.google.de - DATA/DATA/DATA
UPDATE 2: data on result sheet(s) (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim targetRange As Range
Dim Sheet1 As Worksheet
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
'create a new "RESULTS" sheets
Sheets.Add after:=Sheets(1)
Debug.Print "New sheet created: " & ActiveSheet.Name
'set a link on the sheet
Range("A1").Value = iCell.Value 'leave a copy of the url on the sheet as a reference
Set targetRange = Range("A3") 'here we want to get the results
Call ImportData(iCell.Value, targetRange)
Next iCell
End Sub
Sub ImportData(urlToOpen As String, target As Range)
Dim datavalue1, datavalue2, datavalue3
'...
datavalue1 = "data value 1"
datavalue2 = "data value 2"
datavalue3 = "data value 3"
'Save whatever data to the new sheet
target.Offset(0, 0).Value = datavalue1 'Range("A3")
target.Offset(1, 0).Value = datavalue2 'Range("A4")
target.Offset(2, 0).Value = datavalue3 'Range("A5")
Debug.Print "datavalues stored on sheet: " & target.Parent.Name
'...
End Sub
Immediate window:
New sheet created: Sheet2
datavalues stored on sheet: Sheet2

Create a new sheet and coping data

I have the below code which will create a new worksheet on selecting A2 which works fine, but what I am also trying to do is to also copy the data in the row 2 and copy this across into the new sheet. Along with this if I click on A3 to create another worksheet, I want to copy the data in row 3 across to that sheet, and so on.
Any ideas??
Private Sub Worksheet_SelectionChange()
Dim cTab As Integer
cTab = ActiveCell.Row - 1
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A2:A201")) Is Nothing Then
Dim WS1 As Worksheet
On Error Resume Next
Set WS1 = Worksheets(cTab & ".")
If WS1 Is Nothing Then
Application.ScreenUpdating = False
ActiveCell = cTab & "."
Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = cTab & "."
'Sheets("Template").Visible = False
Application.ScreenUpdating = True
Else
Sheets(cTab & ".").Select
End If
End If
End If
End Sub
You could modify your code to something like the below, which should copy the rows as you described.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cTab As Integer
Dim BaseSht As Worksheet
Dim NewSht As Worksheet
Set BaseSht = ActiveSheet
cTab = ActiveCell.Row - 1
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A2:A201")) Is Nothing Then
Dim WS1 As Worksheet
On Error Resume Next
Set WS1 = Worksheets(cTab & ".")
If WS1 Is Nothing Then
Application.ScreenUpdating = False
ActiveCell = cTab & "."
Sheets("Template").Visible = True
Sheets("Template").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = cTab & "."
Set NewSht = ActiveSheet
BaseSht.Select
'Copy row to new sheet
BaseSht.Range(ActiveCell.Address & ":" & BaseSht.Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Address).Copy NewSht.Range("A" & cTab + 1)
'Sheets("Template").Visible = False
Application.ScreenUpdating = True
Else
Sheets(cTab & ".").Select
End If
End If
End If
End Sub

Resources