I have a URL that opens an excel sheet from yahoo finance. I want to take this sheet and then format the data before moving. However the below code finishes without formatting. Possibly to do with it taking 5 seconds for the excel sheet to open. I have tried a delay timer but this doesn't work either. Any idea how to fix, some kind of time killing loop maybe? or maybe a delay and then the need to reference the current sheet somehow.
Sub MAIN()
Call START
Dim i As Integer
Workbooks("book1.xlsb").Sheets("links").Select
For i = 2 To 2
Cells(i, 5).Select
Selection.HYPERLINKS(1).Follow NewWindow:=False, AddHistory:=False
With ActiveSheet.Range("A1:H1").Interior
Columns("a:a").TextToColumns , DataType:=xlDelimited, COMMA:=True
.Pattern = xlSolid
.TintAndShade = -0.5
Range("A:A").NumberFormat = "mm/dd/yyyy"
Range("A:A").HorizontalAlignment = xlLeft
Range("B:F").NumberFormat = "#,##0.00"
Range("G:G").NumberFormat = "#,##0"
Range("A:G").EntireColumn.AutoFit
End With
Sheets("LINKS").Select
Next
Workbooks("book1.xlsb").Sheets("links").Activate
' Windows("book1.xlsb").Activate
' Sheets("LINKS").Select
Call ENDING
End Sub
yahoo finance link
Answer from #Tim Williams using workbooks.open(url).
This not only works, but is much faster and allows me to use the text to columns function at this line also.
Sub MAIN1()
Call START
Dim i As Integer
For i = 2 To 2
xtable = Cells(i, 5)
xsheet = Cells(i, 4).Value
Workbooks.Open xsheet, , , , , , , , 2
Next
Call ENDING
End Sub
Related
I am attempting to build a loop that will look at each row in a column of data and split based on the first instance of an " ". I can get this to work on one line but the loop never activates. I tried my best at formatting this code but could not find a tutorial on how to have the commands appear as different colors and whatnot.
Dim num
Dim RowCnt As Integer
Dim x As Integer
ActiveCell.Select ' the cell to split
RowCnt = Range(Selection, Selection.End(xlDown)).Rows.Count 'determines #rows in column to split
With ActiveCell ' with block
For x = 1 To RowCnt ' define # loops
.Offset(, -1).FormulaR1C1 = "=FIND("" "",RC[1],1)" ' determine first " "
num = .Offset(, -1).Value ' assign the number of chars to 'num'
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(num, 1)), TrailingMinusNumbers:=True ' splits once based on 'num'
.Offset(, -1).ClearContents ' clear
.Offset(1, 0).Activate
Next x
End With
End Sub
I was able to cheat the answer. The issue is the Text to Columns always referred to the first cell until the sub ended. My solution was to make the looped code its own sub and call it in a separate subs loop. That way it ends the sub each time before being called again.
Use this code instead (tested: works!)
Sub updated_delimitter()
start_cell = ActiveCell.AddressLocal
n = Range(start_cell, Range(start_cell).End(xlDown)).Rows.Count 'determines #rows in column to split
Application.ScreenUpdating = False
For x = 0 To n - 1 ' define # loops
this_cell = Range(start_cell).Offset(x).AddressLocal
Range(this_cell).Select
word_ = Range(this_cell).Value
split_at = InStr(word_, " ")
Range(this_cell).TextToColumns Destination:=Range(this_cell), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(split_at, 1)), TrailingMinusNumbers:=True ' splits once based on 'num'
Next
Application.ScreenUpdating = True
End Sub
original code had issues with referencing in relation to 'activecell' which you referenced in the text-to-columns section - removed the with statement and no need to insert num when you can simply store it within VB (getting rid of its placements also mean no code required to remove it...
You could achieve the same in 3 lines of code♦ (w/ for loop) using the following:
Sub test2()
'Range("d2").Select
With Selection
.Offset(, 3).Formula2R1C1 = _
"=LET(x_,RC[-3]:OFFSET(RC[-3],MATCH(0,IFERROR(SEARCH("""",RC[-3]:OFFSET(RC[-3],ROWS(C[-3])-ROWS(RC[-3])-1,0)),0),0)-1,0),IF(ISODD(SEQUENCE(1,2,1,1)),MID(x_,1,IFERROR(SEARCH("" "",x_)-1,LEN(x_))),IF(ISERROR(SEARCH("" "",x_)),"""",MID(x_,SEARCH("" "",x_)+2,LEN(x_)))))"
Range(.AddressLocal, .End(xlDown).Offset(, 1)).Value = Range(Replace(.Offset(, 3).AddressLocal, "$", "") & "#").Value
.Offset(, 3).ClearContents
End With
End Sub
This uses the function:
=LET(x_,D2:OFFSET(D2,MATCH(0,IFERROR(SEARCH("",D2:OFFSET(D2,ROWS(D:D)-ROWS(D2)-1,0)),0),0)-1,0),IF(ISODD(SEQUENCE(1,2,1,1)),MID(x_,1,IFERROR(SEARCH(" ",x_)-1,LEN(x_))),IF(ISERROR(SEARCH(" ",x_)),"",MID(x_,SEARCH(" ",x_)+2,LEN(x_)))))
... which is an array function that reproduces the original list with relevant cells split as req.
REVISED
Here for sample file (requires Microsoft Onedrive a/c - read only file avail.)
♦ Office 365 compatibility; '3 lines' ignoring with/end/sub/etc.
ta 💪
I am very much of a beginner with VBA so forgive any sloppiness. I am looking for a macro or another way to print labels on a Zebra printer as soon as a value is inputted into a specific column in a spreadsheet. This is not designed to work for as soon as the value is inputted, I was just testing to see whether the printer prints a BARCODE which is the most important part of this, so I used the code below which I lifted from here. The print area is the selected cell. It contains a 12-digit number to be printed as a barcode label:
Sub ZEBRA_LABEL()
Dim r As Long
With ActiveSheet
With .PageSetup
.FitToPagesWide = 1
.FitToPagesTall = False
End With
For r = 5 To 20
If Range("E" & r) <> "" Then 'the r values correspond with row numbers
With .PageSetup
.PrintArea = "$B$" & r & ":$E$" & r + 3
ActiveSheet.PrintOut copies:=Range("A" & r).Value, collate:=True, IgnorePrintAreas:=False
End With
End If
Next
End With
End Sub
However, this gives me an "Run time error 1004 - Application-defined or Object-defined error" (which makes sense because Cell.Value is not an object) and if I remove the .Value from the ActiveSheet.PrintOut statement the Zebra printer does not print a barcode but the appearance of the cell itself.
Anyone have any ideas about how to make this work? I tried almost every solution I could find online but nothing has worked for me
Can anyone help with the following.
Working in excel. Have created a table that is filled using a form. Cells in range a:1 to J:31 (Table1).
The form auto completes the table, however when an entry is deleted (anywhere) in the table I need the form to fill those empty spcaes. At the moment once the table is complete even when information I deleted no new entries can be entered using the form. In addition i need the form to fill the first empty cell.
Lets say that the only space available that I have is row 12, I want to be able to put the information there using my userform.
The table is an admissions to a hospital sheet including name, number, bedroom, date of arrival, doctor and other such info, filled across. The main point is that I don't want to create another row to enter data, the data should be just in the range of the table a:1 to J:31
I have this code in vba
Private Sub CommandButtonSave_Click()
Dim fill As Lonng
Sheets("Ward Planner").Activate
fill = WorksheetFunction.CountA(Range("Table1")) + 1
Cells(fill, 1).Value = ComboBoxBed
Cells(fill, 2).Value = TextBoxName.Text
Cells(fill, 3).Value = ComboBoxConsultant
Cells(fill, 4).Value = TextBoxPcn.Text
Cells(fill, 5).Value = TextBoxDoa.Text
Cells(fill, 6).Value = ComboBoxGender
Cells(fill, 7).Value = ComboBoxStatus
Cells(fill, 8).Value = ComboBoxDiet
Cells(fill, 9).Value = TextBoxComments.Text
End Sub
It looks like you need a test to see whether a blank row is available or not - then some code to find that row (based on column A) before pasting your data to it. The following code is untested but should work given the description in your question. Please try it & let me know how it goes.
Private Sub CommandButtonSave_Click()
Dim c As Range, fill As Long, ws As Worksheet
Set ws = Sheets("Ward Planner")
If Application.WorksheetFunction.CountBlank(ws.Range("A1:A31")) = 0 Then
MsgBox "No available rows"
Exit Sub
End If
For Each c In ws.Range("A1:A31")
If c.Value = "" Then
fill = c.Row
'ws.Cells(fill, 1).Value...etc" code goes here
'copy your current code - but please note the "ws." prefix
Exit Sub
End If
Next c
End Sub
I found that this code works too, just in case someone would like to try both.
Dim fill As Long
Sheets("Ward_Planner").Activate
On Error Resume Next
fill = Range("A2:A29").SpecialCells(xlBlanks)(1).Row
On Error GoTo 0
If fill = 0 Then
MsgBox "all beds are filled"
Exit Sub
End If
Cells(fill, 1).Value = ComboBoxBed.Value
Cells(fill, 2).Value = TextBoxName.Value***
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub
I have written an Excel VBA to copy data from selected cells from one workbook sheet to another. Here it is working fine upto certain cells, after pasting some values, after sometime VBA is pasting empty values. I mean eventhough the source cell is not empty, it is pasting empty values. I have put breakpoint and saw, but the value was there. Please help me to solve this issue.
The code is as follows.
Set objClickScriptWB = objExcelWB.Workbooks.Open(SourceWBPath)
For intSheet = 9 To 12 'objClickScriptWB.Worksheets.Count
If InStr(1, objClickScriptWB.Worksheets(intSheet).Name, "SC", vbTextCompare) > 0 Then
blnScriptSheet = 1
objClickScriptWB.Worksheets(intSheet).Activate
For r = 24 To objClickScriptWB.Worksheets(intSheet).UsedRange.Rows.Count
If Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Trim(LCase("Transaction")) And Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Empty And objClickScriptWB.Worksheets(intSheet).Cells(r, 6).MergeArea.Cells.Count = 1 Then
objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Select
If blnCompSht = 0 Then
Set objComparisonSheet = ThisWorkbook.Worksheets.Add
objComparisonSheet.Name = "Comparison"
objComparisonSheet.Activate
objComparisonSheet.Cells(2, 2).Value = "Clickscript Transaction names"
i = 3
objExcelWB.Selection.Copy
objComparisonSheet.Activate
objComparisonSheet.Cells(i, 2).Select
'Sheet3.Range("B2").Select
'objComparisonSheet.Range("B" & i).PasteSpecial Paste:=xlPasteValues
objComparisonSheet.Paste
'Sheet2.Range("G2").Cells
i = i + 1
blnCompSht = 1
'Application.Wait (Now + TimeValue("00:00:01"))
ElseIf blnCompSht = 1 Then
ThisWorkbook.Worksheets("Comparison").Activate
Dim LastRow As Integer
For intRow = 2 To ThisWorkbook.Worksheets("Comparison").Rows.Count
If ThisWorkbook.Worksheets("Comparison").Cells(intRow, 2).Value = Empty Then
i = intRow
Exit For
End If
Next
objExcelWB.Selection.Copy
ThisWorkbook.Worksheets("Comparison").Cells(i, 2).Select
'ThisWorkbook.Worksheets("Comparison").Range("B" & intRow).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets("Comparison").Paste
i = i + 1
'Application.Wait (Now + TimeValue("00:00:01"))
End If
'End If
'Next
'Call CompareTxnNames(objClickScriptWB.Worksheets(intSheet).Name)
End If
'Next
Next
End If
Next
End Sub
Please help me
Thanks
You could also directly apply the value of one cell to the other cell with a code like this:
CellTarget.Value2 = CellSource.Value2
Or in your case:
objComparisonSheet.Cells(i, 2).Value2 = objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value2
Side note:
Get into the habit of using Value2 for that is the true value of the cell compared to Value which is the value with formatting applied to it. The latter is slower and in case of date values can give wrong days and months when you arent using the US dateformat in your excel.