Closed. This question is off-topic. It is not currently accepting answers.
Want to improve this question? Update the question so it's on-topic for Stack Overflow.
Closed 10 years ago.
Improve this question
As per title, the codes below are located in my Private Sub Workbook_open(). Therefore every time I open my workbook it is slow. How do I get to optimize the code to run fastest? Any help is appreciated.
'Sheets("Summary(FG)") ComboBox1 items
For b = 3 To Sheets("CustomerList").Cells(3, 2).SpecialCells(xlLastCell).row
If Sheets("CustomerList").Cells(b, 2) <> "" Then
Worksheets("Summary(FG)").ComboBox1.AddItem (Sheets("CustomerList").Cells(b, 2))
Else
End If
Next
'Sheets("Summary(RawMat)") ComboBox1 items
For a = 2 To Sheets("RawMatList").Cells(2, 2).SpecialCells(xlLastCell).Column
If Sheets("RawMatList").Cells(2, a) <> "" Then
Worksheets("Summary(RawMat)").ComboBox1.AddItem (Sheets("RawMatList").Cells(2, a))
End If
Next
'sheets("Summary(WIP)") ComboBox1 items
For c = 3 To Sheets("WIPList").Cells(3, 2).SpecialCells(xlLastCell).row
If Sheets("WIPList").Cells(c, 2) <> "" Then
Worksheets("Summary(WIP)").ComboBox1.AddItem (Sheets("WIPList").Cells(c, 2))
End If
Next
For Each Worksheet In Worksheets
Application.Goto Reference:=Range("A1"), Scroll:=True
Next Worksheet
It looks like your loop is iterating through every row or every column on a worksheet. Instead of using the last row or last column try using the last used row or last used column. This way instead of moving through thousands of blank rows you only check rows containing data.
Try:
'Sheets("Summary(FG)") ComboBox1 items
For b = 3 To Sheets("CustomerList").UsedRange.Rows.Count
If Sheets("CustomerList").Cells(b, 2) <> "" Then
Worksheets("Summary(FG)").ComboBox1.AddItem (Sheets("CustomerList").Cells(b, 2))
Else
End If
Next
'Sheets("Summary(RawMat)") ComboBox1 items
For a = 2 To Sheets("RawMatList").UsedRange.Columns.Count
If Sheets("RawMatList").Cells(2, a) <> "" Then
Worksheets("Summary(RawMat)").ComboBox1.AddItem (Sheets("RawMatList").Cells(2, a))
End If
Next
'sheets("Summary(WIP)") ComboBox1 items
For c = 3 To Sheets("WIPList").UsedRange.Rows.Count
If Sheets("WIPList").Cells(c, 2) <> "" Then
Worksheets("Summary(WIP)").ComboBox1.AddItem (Sheets("WIPList").Cells(c, 2))
End If
Next
For Each Worksheet In Worksheets
Application.Goto Reference:=Range("A1"), Scroll:=True
Next Worksheet
Related
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I have a task to create a loop that fills in columns with the following data:
Column A should populate with a number from 1 to 10000,
Column B should populate with a today's date and increment with the number,
Column C should populate with number of a day of the week so repeating from 1 to 7 every week,
Column D should populate with a day of the week from Monday to Sunday (text).
I think this could be achieved with a For ...Next loop. More complicated would be with the dates...
Could you please give me a hint how to go about this?
THank you
try this
Sub mm()
Dim i As Long
Dim weekDayNames As Variant
With Range("A1:A10000")
.Formula = "=ROW()"
.Offset(, 1).FormulaR1C1 = "=Today()+RC1-1"
.Offset(, 2).FormulaR1C1 = "=WEEKDAY(RC2,1)"
With .Offset(, 1).Resize(, 2)
.Value = .Value
End With
weekDayNames = Application.Transpose(.Offset(, 2).Value)
For i = 1 To UBound(weekDayNames)
weekDayNames(i) = WeekdayName(weekDayNames(i), False, vbSunday)
Next
.Offset(, 3).Value = Application.Transpose(weekDayNames)
End With
End Sub
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 5 years ago.
Improve this question
I am looking for a macro that will insert rows based on cell values in column E. If the cells above and below have a difference more than 0.002, I want two rows inserted in between. Below is an example of what I would like to have the data to look like
EX.
Column E
42948.745
(Insert Blank (Row)
(Insert Blank Row)
42948.758
(Insert Blank (Row)
(Insert Blank Row)
42948.898
42948.900
42948.901
(Insert Blank (Row)
(Insert Blank Row)
42948.933
Even better if the code included a way to fill the cells in the blank row with + 0.001 from the above cell and -0.001 from the bottom cell. Ex.
42948.901
Insert 42948.902
Insert 42948.932
42948.933
Thank you so much as I have been trying to figure this out forever. I have many shortcuts but no solutions.
The following code will do what you want
Sub InsertBlankRowAndSetValue()
Dim yourColumn As String
Dim rowToStart As Integer
Dim nameOfYourSheet As String
Dim currentValue As Double
Dim previousValue As Double
'EDIT VALUES HERE
yourColumn = "E"
rowToStart = 1
nameOfYourSheet = "Name of your sheet"
With ThisWorkbook.Sheets(nameOfYourSheet)
'For each cell in the column from the end
For i = .Cells(.Rows.Count, yourColumn).End(xlUp).Row To rowToStart + 1 Step -1
currentValue = CDbl(.Range(yourColumn & i).Value)
previousValue = CDbl(.Range(yourColumn & i).Offset(-1, 0).Value)
'If the difference with the previous > 0.002
If ((currentValue - previousValue) > 0.002) Then
'Add rows and set values
.Rows(i).EntireRow.Insert Shift:=xlDown
.Range(yourColumn & i).Value = currentValue + 0.001
.Rows(i).EntireRow.Insert Shift:=xlDown
.Range(yourColumn & i).Value = previousValue + 0.001
End If
Next i
End With
End Sub
Explanations
Edit the name of your sheet in nameOfYourSheet = "Name of your sheet" to make it work.
I go through every value in your column starting from the bottom (less problems with index when you add a row above) and if the difference is more than 0.002 then I add a row and put +0.001 as it's value.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 6 years ago.
Improve this question
I do know the formula but not sure how to translate into VBA.
Need a VBA script to do the following.
If cell D contains Debit, then value in F multiply -1
If cell D contains Credit, then value in F multiply 1
Loop until last row.
Use this macro:
Sub subMultiply()
For Each cel In Range("D1:D" & Range("D1").End(xlDown).Row)
If cel.Value = "Debit" Then
cel.Offset(0, 2).Value = Val(cel.Offset(0, 2)) * (-1)
ElseIf cel.Value = "Credit" Then
cel.Offset(0, 2).Value = Val(cel.Offset(0, 2)) * 1
End If
Next
End Sub
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 7 years ago.
Improve this question
New to vba. Just starting to learn. I want to pull some specific data from a website.Code I am trying to modify is from Ron Retrieving specific data from website through excel.
Now this code work on a single url. I have urls in Column A of excel sheet and I want to macro to go one by one to all urls and paste results in Column B C D respectively.
Tried as best as my limited knowledge.
Regards
The main sub will get the ratings and the number of reviews for each URL in column A and will place them in Column B and C. I hope this help you a little.
Sub main()
Dim l As Long
l = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To l
test Range("A" & i)
Next
End Sub
Sub test(URL As Range)
my_url = URL.Value
Set html_doc = CreateObject("htmlfile")
Set xml_obj = CreateObject("MSXML2.XMLHTTP")
xml_obj.Open "GET", my_url, False
xml_obj.send
html_doc.body.innerhtml = xml_obj.responseText
Set xml_obj = Nothing
Set Results = html_doc.body.getElementsByTagName("i")
For Each itm In Results
If InStr(1, itm.outerhtml, "star-img", vbTextCompare) > 0 Then
numb_stars = itm.getAttribute("title")
Exit For
Else
End If
Next
Set Results = html_doc.body.getElementsByTagName("span")
For Each itm In Results
If InStr(1, itm.outerhtml, "reviewCount", vbTextCompare) > 0 Then
numb_rev = itm.innertext
Exit For
Else
End If
Next
URL.Offset(0, 1) = numb_stars
URL.Offset(0, 2) = numb_rev
End Sub
Preview of my output:
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question does not appear to be about a specific programming problem, a software algorithm, or software tools primarily used by programmers. If you believe the question would be on-topic on another Stack Exchange site, you can leave a comment to explain where the question may be able to be answered.
Closed 8 years ago.
Improve this question
I'm write in a cell 1, then put the mouse over the black square at the bottom-right corner of that cell, right click and drag.
Principal question - I do not want to use a mouse. And look for script or keyboard hotkeys to got similar numbers
1 3
3 6
5 9
from keyword selected
1 3
3 6
I put the following macros in my Personal Macro Workbook and assigned a keyboard shortcut.
Sub FillSeries()
Dim lFirstBlank As Long
If TypeName(Selection) = "Range" Then
If Selection.Columns.Count = 1 Or Selection.Rows.Count = 1 Then
lFirstBlank = GetFirstBlank(Selection)
If lFirstBlank = 0 Then
SelectAdjacentCol
lFirstBlank = GetFirstBlank(Selection)
End If
If lFirstBlank > 1 Then
If Selection.Columns.Count = 1 Then
Selection.Cells(1).Resize(lFirstBlank - 1).AutoFill _
Selection, xlFillSeries
ElseIf Selection.Rows.Count = 1 Then
Selection.Cells(1).Resize(, lFirstBlank - 1).AutoFill _
Selection, xlFillSeries
End If
End If
End If
End If
End Sub
Function GetFirstBlank(rRng As Range) As Long
Dim i As Long
i = 0
For i = 1 To rRng.Cells.Count
If IsEmpty(rRng.Cells(i)) Then
GetFirstBlank = i
Exit For
End If
Next i
End Function
Sub SelectAdjacentCol()
Dim rAdjacent As Range
If TypeName(Selection) = "Range" Then
If Selection.Column > 1 Then
If Not IsEmpty(Selection.Offset(0, -1).Value) Then
With Selection.Offset(0, -1)
Set rAdjacent = .Parent.Range(.Cells(1), .End(xlDown))
End With
Selection.Resize(rAdjacent.Cells.Count).Select
End If
End If
End If
End Sub
See also http://dailydoseofexcel.com/archives/2008/07/17/fillseries-keyboard-shortcut/
Update
If you only want to fill columns and you want to fill all the columns in a selection, then the below code should do what you want. It also looks at the NumberFormat of the last cell in the column and changes the NumberFormat for filled cells back to that. Picking the last cell is a little arbitrary, but it is what it is.
Sub FillSeriesForAllColumns()
Dim lFirstBlank As Long
Dim rCol As Range
Dim sOldNumberFormat As String
If TypeName(Selection) = "Range" Then
For Each rCol In Selection.Columns
sOldNumberFormat = Selection.Cells(Selection.Cells.Count).NumberFormat
lFirstBlank = GetFirstBlank(rCol)
If lFirstBlank = 0 Then
SelectAdjacentCol
lFirstBlank = GetFirstBlank(rCol)
End If
If lFirstBlank > 1 Then
rCol.Cells(1).Resize(lFirstBlank - 1).AutoFill _
rCol, xlFillSeries
End If
rCol.Offset(lFirstBlank - 1, 0).Resize(rCol.Row - (lFirstBlank - 1)).NumberFormat = sOldNumberFormat
Next rCol
End If
End Sub
Using the arrow keys select the column section including the header cell:
Hold down the Alt key and touch hfis sequentially. Then release the Alt key and touch the Enter key
..after: