I have tons of data and I need to optimize this lines but i simply do not know how ...
Some lines of "x" will be black so I don't know how to use arrays without including this blank lines or how to write them without them.
x,a,b & d are variable numbers.
a = Sheets("MODULOS").Range("a1048576").End(xlUp).Row
b = Sheets("TODO").Range("a1048576").End(xlUp).Row
For x = 1 To b
Range("Z1").Select
ActiveCell.Offset(x, 0).Select
For i = 1 To (a - 1)
If ActiveCell.Value <> 0 Then
d = Sheets("AGREGADO").Range("a1048576").End(xlUp).Row
Sheets("AGREGADO").Cells(d + 1, 1).Value = Sheets("TODO").Cells(x + 1, 7).Value
Sheets("AGREGADO").Cells(d + 1, 3).Value = Sheets("TODO").Cells(x + 1, 25 + i).Value
Sheets("AGREGADO").Cells(d + 1, 2).Value = Sheets("TODO").Cells(1, 25 + i).Value
Sheets("AGREGADO").Cells(d + 1, 4).Value = Sheets("TODO").Cells(x + 1, 33 + a).Value
End If
ActiveCell.Offset(0, 1).Select
Next i
Next x
There are a few way to make your code faster:
Summary (ranked by importance):
dis-activate Automatic Calculation and screen updating (as in the
comment from Tomjohnriddle)
Avoid the .Select and ActiveCell
Use WITH where possible when working with objects
In your code it would look like this:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim ra As Range
a = Sheets("MODULOS").Range("a1048576").End(xlUp).Row
b = Sheets("TODO").Range("a1048576").End(xlUp).Row
For x = 1 To b
ra = Cells(1 + x, 26)
With Sheets("AGREGADO")
For i = 1 To (a - 1)
If ra.Value <> 0 Then
d = Sheets("AGREGADO").Range("a1048576").End(xlUp).Row
.Cells(d + 1, 1).Value = Sheets("TODO").Cells(x + 1, 7).Value
.Cells(d + 1, 3).Value = Sheets("TODO").Cells(x + 1, 25 + i).Value
.Cells(d + 1, 2).Value = Sheets("TODO").Cells(1, 25 + i).Value
.Cells(d + 1, 4).Value = Sheets("TODO").Cells(x + 1, 33 + a).Value
End If
ra = Cells(1 + x, 26 + 1)
Next i
Next x
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Related
I created an array index (tickerIndex).
When I run the code, I get the error
subscript out of range
When I run the code, for some reason, the tickerIndex variable counts up to 13 which is 1 more than the size of the array.
The size of the tickers array is 12.
The tickerIndex variable is used to loop the tickers, tickerVolumes, tickerStartingPrices, and tickerEndingPrices arrays.
Dim tickers(12) As String
tickers(0) = "AY"
tickers(1) = "CSIQ"
tickers(2) = "DQ"
tickers(3) = "ENPH"
tickers(4) = "FSLR"
tickers(5) = "HASI"
tickers(6) = "JKS"
tickers(7) = "RUN"
tickers(8) = "SEDG"
tickers(9) = "SPWR"
tickers(10) = "TERP"
tickers(11) = "VSLR"
'Activate data worksheet
Worksheets(yearValue).Activate
'Get the number of rows to loop over
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim tickerIndex As Integer
tickerIndex = 0
Dim tickerVolumes(12) As Long
Dim tickerStartingPrices(12) As Single
Dim tickerEndingPrices(12) As Single
For tickerIndex = 0 To 11
ticker = tickers(tickerIndex)
tickerVolumes(tickerIndex) = 0
Worksheets(yearValue).Activate
For i = 2 To RowCount
'Increase volume for current ticker [error on this line]
***If Cells(i, 1).Value = tickers(tickerIndex) Then***
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(i, 8).Value
End If
' Check if the current row is the first row with the selected tickerIndex.
If Cells(i - 1, 1).Value <> tickers(tickerIndex) And Cells(i, 1).Value = tickers(tickerIndex) Then
tickerStartingPrices(tickerIndex) = Cells(i, 6).Value
End If
'check if the current row is the last row with the selected ticker
'If the next row's ticker doesn't match, increase the tickerIndex.
If Cells(i + 1, 1).Value <> tickers(tickerIndex) And Cells(i, 1).Value = tickers(tickerIndex) Then
tickerEndingPrices(tickerIndex) = Cells(i, 6).Value
End If
'Increase the tickerIndex if the next row’s ticker doesn’t match the previous row’s ticker.
If Cells(i + 1, 1).Value <> Cells(i - 1, 1).Value Then
tickerIndex = tickerIndex + 1
End If
Next i
Next tickerIndex
'Loop through arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("AllStocksAnalysis").Activate
Cells(4 + i, 1).Value = tickers(tickerIndex)
Cells(4 + i, 2).Value = tickerVolumes(tickerIndex)
Cells(4 + i, 3).Value = (tickerEndingPrices(tickerIndex) / tickerStartingPrices(tickerIndex)) - 1
Next i
Don't hard code your array bounds.
Do this
For tickerIndex = LBound(tickers) To UBound(tickers)
ticker = tickers(tickerIndex)
...
or better yet this
For Each ticker In tickers
...
instead of this
For tickerIndex = 0 To 11
ticker = tickers(tickerIndex)
...
Problem
How can you horizontally align values in separate columns, and apply a dynamic formula? Preemptive thank you for any help or clues! The code pasted below works, in so far as it reaches halfway to the end destination. But how to accomplish the last two objectives?
1) Sum each range
2) Align the ranges horizontally
A sample sheet containing customer id, item and prices. Sales from Monday on the left, Tuesday on the right.
Current results
Desired results
Align cust id on rows A and E, with an associated sum. Notice how each yellow line contains cust id for identification, as well as associated Sum total.
Existing VBA Code
Sub AlignAndMatch()
'backup sheet
ActiveSheet.Copy after:=Sheets(Sheets.Count)
'Insert rows where current cell <> cell above
Dim i, totalrows As Integer
Dim strRange As String
Dim strRange2 As String
'----------------------------------------
'Monday sort table
Range("A2:C65536").Select
Selection.Sort Key1:=Range("A2:C65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Monday insert loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "A" & i
strRange2 = "A" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Monday footer row loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("A" & i).Value) And Not IsEmpty(Range("A" & i + 1).Value) Then
Range("A" & i).Value = Range("A" & i + 1).Value
Range("B" & i).Value = "Sum"
End If
Loop
'----------------------------------------
'Tuesday sort table
Range("E2:G65536").Select
Selection.Sort Key1:=Range("E2:G65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Tuesday insert loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "E" & i
strRange2 = "E" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 5), Cells(i + 2, 7)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Tuesday footer row loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("E" & i).Value) And Not IsEmpty(Range("E" & i + 1).Value) Then
Range("E" & i).Value = Range("E" & i + 1).Value
Range("F" & i).Value = "Sum"
End If
Loop
End Sub
If I needed something like that I might think twice what I want and why: if the original day lists don't come from somehwere, you could put everything into one list and make some pivots...
But. Here's some idea, playing with the arrays again and there's probably work to do, but does this help:
Option Base 1
Sub ReLists()
Dim ListSheet As Worksheet
Dim DayCorners() As Range
Dim Day()
Dim Days As Integer
Dim CustIDs()
Dim CustomerRow() 'for placement in the final list
Dim DayList()
Dim MaxCustIDs As Integer
Dim NewCustID As Boolean
Days = 2
MaxCustIDs = 5
ReDim DayCorners(Days)
ReDim Day(Days)
ReDim CustomerRow(MaxCustIDs + 2)
CustomerRow(1) = 0
ReDim CustIDs(MaxCustIDs)
ReDim DayItems(1, 1)
Set ListSheet = Worksheets("Sheet1")
Set DayCorners(1) = ListSheet.Range("A2")
Set DayCorners(2) = ListSheet.Range("E2")
For d = 1 To Days
With ListSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=DayCorners(d)
.SetRange Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Day(d) = Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
If UBound(Day(d), 1) > UBound(DayItems, 2) Then
ReDim DayItems(Days, UBound(Day(d)))
End If
Next d
CustIDCount = 0
For d = 1 To Days
For r = 1 To UBound(Day(d), 1)
NewCustID = True
For u = 1 To UBound(CustIDs)
If CustIDs(u) = Day(d)(r, 1) Then NewCustID = False
Next u
If NewCustID Then
CustIDCount = CustIDCount + 1
CustIDs(CustIDCount) = Day(d)(r, 1)
End If
Next r
Next d
With Worksheets.Add(After:=Worksheets(ListSheet.Index))
Set DayCorners(1) = .Range("A2")
Set DayCorners(2) = .Range("E2")
End With
ReDim DayList(Days, CustIDCount, 100, 3)
For d = 1 To Days
For c = 1 To CustIDCount
rc = 1
For r = 1 To UBound(Day(d), 1)
If Day(d)(r, 1) = CustIDs(c) Then
DayList(d, c, rc, 1) = Day(d)(r, 1)
DayList(d, c, rc, 2) = Day(d)(r, 2)
DayList(d, c, rc, 3) = Day(d)(r, 3)
rc = rc + 1
End If
Next r
If CustomerRow(c) + rc + 2 > CustomerRow(c + 1) Then
CustomerRow(c + 1) = CustomerRow(c) + rc + 1
End If
Next c
If CustomerRow(c - 1) + rc + 2 > CustomerRow(c) Then
CustomerRow(c) = CustomerRow(c) + rc
End If
Next d
For d = 1 To Days
With DayCorners(d).Offset(-1, 0).Range("A1:C1")
.Value = Array("cust id", "item", "Price")
'formatting
End With
For c = 1 To CustIDCount
SumFormula = "=SUM(R[1]C:R[" & (CustomerRow(c + 1) - CustomerRow(c) - 1) & "]C)"
With DayCorners(d).Offset(CustomerRow(c), 0).Range("A1:D1")
If Not IsEmpty(DayList(d, c, 1, 1)) Then
.Value = Array(CustIDs(c), "Sum", SumFormula, "")
End If
.Interior.Color = 65535
End With
For rc = 1 To UBound(Day(d), 1)
If IsEmpty(DayList(d, c, rc, 1)) Then Exit For
DayCorners(d).Offset(CustomerRow(c) + rc, 0) = DayList(d, c, rc, 1)
DayCorners(d).Offset(CustomerRow(c) + rc, 1) = DayList(d, c, rc, 2)
DayCorners(d).Offset(CustomerRow(c) + rc, 2) = DayList(d, c, rc, 3)
Next rc
Next c
Next d
End Sub
I believe the solution is to simulate an SQL full outer join, via VBA. I'll start hacking away at it. Should be a fun personal challenge. I'll try to update this answer once I find the final solution.
The direction I'm following is here.
Writing rudimentary VBA to populate a 2 dimensional array filled with two sums one consisting of the odd columns the other is the sum of the even columns, totaled over a variable amount of rows stored in another array. the two dimensional array then prints on a seperate worksheet. I wrote code which succesfully completed this task on two other worksheets in the same file with slightly different sized arrays, but it populates the destination range with zeros when adjusted for the new input and output.
code in question:
Sub dad()
Dim i As Integer, j As Integer, units As Double, value As Double, mr(1 To 655, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1010").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1010totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 655
mr(i, 1) = Worksheets("1010totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 655
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 655
For j = 2 To 3
Worksheets("1010totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
Original code that works on the other worksheets:
Sub ded()
Dim i As Integer, j As Integer, units As Double, value As Double, n As Integer, mr(1 To 756, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1030").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1030totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 756
mr(i, 1) = Worksheets("1030totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 756
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 756
For j = 2 To 3
Worksheets("1030totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
I have hobby programmed this a VBA macro for extracting and plotting data from some text files in Excel. I recentyl tried it on a slightly bigger file, about 700 lines and 1 too three rows to be averaged and plotted. It is painfully slow and i think it can be inproved using arrays but my previous atempt at usings arrays in VBA was not very successfull so i thought i would ask you guys for some advice on how to turn the following code from a for loop into a array addition.
Here is the part I want to convert. Basically it goes line to line and averages the values from a specific but unknown number of columns.
' Add all Stribeckcurves
l = 8
For k = skriv + 4 To skriv + 45
meanSpeed = 0
meanTraction = 0
For m = 1 To NumberOfColumns
meanSpeed = meanSpeed + shtraw.Cells(k, i + 2 * m - 2)
meanTraction = meanTraction + shtraw.Cells(k, i + 2 * m - 1)
Next m
shtmean.Cells(l, 3 * j - 2) = meanSpeed / NumberOfColumns
shtmean.Cells(l, 3 * j - 1) = meanTraction / NumberOfColumns
l = l + 1
Next k
Here i the whole code block for reference:
Sub loppthroughfolder()
Dim mainwb As Workbook, Datwb As Workbook, filename As String, arrFileName() As String, shtraw As Worksheet, shtmean As Worksheet, lastrow As Long, lastColumn As Long, j As Integer, profile As String, duplicateArray As Variant, meanSpeed As Double, meanTraction As Double
Set mainwb = ActiveWorkbook
Worksheets("rawData").Cells.Clear
Worksheets("mean").Cells.Clear
Charts("plot").Activate
For Each s In ActiveChart.SeriesCollection
s.Delete
Next s
Set shtraw = ThisWorkbook.Worksheets("rawData")
Set shtmean = ThisWorkbook.Worksheets("mean")
Set shtcon = ThisWorkbook.Worksheets("configure")
Set shtplot = ThisWorkbook.Charts("plot")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1)
End With
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
Set folderObj = fileSystemObject.getfolder(MyFolder)
shtraw.Select
For Each fileObj In folderObj.Files 'loop through files
If (fileSystemObject.GetExtensionName(fileObj.Path) = "txt") Then
If Not fileObj.Attributes And 2 Then
arrFileName = Split(fileObj.Path, "\")
Path = "TEXT:" & fileObj.Path
filename = arrFileName(UBound(arrFileName))
'Get the filename without the.mtmd
CustName = Mid(filename, 1, InStr(filename, ".") - 1)
range("$A$1").value = CustName
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileObj.Path, Destination:=range("$A$2"))
.name = filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If 'end if hidden if statement
End If 'end of txt
Next fileObj 'close loop
range("$A$1:$B$1").Delete shift:=xlToLeft
lastrow = shtraw.UsedRange.Rows.Count
lastColumn = shtraw.UsedRange.Columns.Count
' Some formating before the sorting
For i = 1 To lastColumn Step 2
shtraw.Cells(9, i + 1) = shtraw.Cells(9, i)
Next i
' Sort the result after the second line in the comments
shtraw.Sort.SortFields.Clear
shtraw.Sort.SortFields.Add Key:=range(shtraw.Cells(9, 1), shtraw.Cells(9, lastColumn)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With shtraw.Sort
.SetRange range(Cells(1, 1), Cells(lastrow, lastColumn))
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
duplicateArray = findCopies(shtraw, lastColumn)
j = 1
For Each i In duplicateArray
' Find out how many columns there are for this FM
If j = UBound(duplicateArray) + 1 Then
NumberOfColumns = (lastColumn + 1 - duplicateArray(j - 1)) / 2
Else
NumberOfColumns = (duplicateArray(j) - duplicateArray(j - 1)) / 2
End If
' Find out how many rows of comments there are
commentsEnd = findFunc("rawData", i, "Number of steps in profile:", 0, "top") - 1
' Add the test name and sample name
shtmean.Cells(1, 3 * j - 2) = shtraw.Cells(1, i)
shtmean.Cells(2, 3 * j - 2) = shtraw.Cells(6, i + 1)
' Add all row of comments
l = 3
For k = 8 To commentsEnd
shtmean.Cells(l, 3 * j - 2) = shtraw.Cells(k, i)
l = l + 1
Next k
' Extract the profile name
profile = Mid(shtraw.Cells(4, i + 1).value, InStrRev(shtraw.Cells(4, i + 1).value, "Profiles\") + 9, InStrRev(shtraw.Cells(4, i + 1).value, "."))
shtmean.Cells(5, 3 * j - 2) = Mid(profile, 1, InStr(profile, ".") - 1)
' Add the time and date the test started
shtmean.Cells(6, 3 * j - 2) = Mid(shtraw.Cells(12, i).value, InStrRev(shtraw.Cells(12, i).value, "at") + 3)
' Find the last Stribeck curve
skriv = findFunc("rawData", i + 1, shtcon.Cells(9, 2), lastrow, "bottom")
' Time step or Stribeck curve
If shtcon.Cells(9, 2) = "STRIBECK" Then
' Add all Stribeckcurves
l = 8
For k = skriv + 4 To skriv + 45
meanSpeed = 0
meanTraction = 0
For m = 1 To NumberOfColumns
meanSpeed = meanSpeed + shtraw.Cells(k, i + 2 * m - 2)
meanTraction = meanTraction + shtraw.Cells(k, i + 2 * m - 1)
Next m
shtmean.Cells(l, 3 * j - 2) = meanSpeed / NumberOfColumns
shtmean.Cells(l, 3 * j - 1) = meanTraction / NumberOfColumns
l = l + 1
Next k
ElseIf shtcon.Cells(9, 2) = "BOD_TIMED" Then
l = 8
For k = skriv + 4 To skriv + 723
meanSpeed = 0
meanTraction = 0
For m = 1 To NumberOfColumns
meanSpeed = meanSpeed + shtraw.Cells(k, i + 2 * m - 2)
meanTraction = meanTraction + shtraw.Cells(k, i + 2 * m - 1)
Next m
shtmean.Cells(l, 3 * j - 2) = meanSpeed / NumberOfColumns
shtmean.Cells(l, 3 * j - 1) = meanTraction / NumberOfColumns
l = l + 1
Next k
Else
MsgBox "Skriv STRIBECK eller BOD_TIMED"
Exit Sub
End If
' Plot it
With Charts("plot")
.ChartType = xlXYScatterSmooth
.SeriesCollection.NewSeries
.SeriesCollection(j).name = shtmean.Cells(4, 3 * j - 2)
.SeriesCollection(j).XValues = range(shtmean.Cells(8, 3 * j - 2), shtmean.Cells(l - 1, 3 * j - 2))
.SeriesCollection(j).Values = range(shtmean.Cells(8, 3 * j - 1), shtmean.Cells(l - 1, 3 * j - 1))
.SeriesCollection(j).Format.Fill.Visible = msoFalse
.SeriesCollection(j).Format.Line.Visible = msoFalse
End With
j = j + 1
Next i
' Edit plot
If shtcon.Cells(9, 2) = "STRIBECK" Then
With Charts("plot")
'X axis name
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Speed (mm/s)"
'y-axis name
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Friction coefficient"
'Scale Axis
.Axes(xlCategory).ScaleType = xlLogarithmic
.Axes(xlCategory).MinimumScale = 4.5
.Axes(xlCategory).MaximumScale = 3500
End With
ElseIf shtcon.Cells(9, 2) = "BOD_TIMED" Then
With Charts("plot")
'X axis name
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Time (s)"
'y-axis name
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Friction coefficient"
'Scale Axis
.Axes(xlCategory).ScaleType = xlScaleLinear
.Axes(xlCategory).MinimumScale = 10
.Axes(xlCategory).MaximumScale = 7200
End With
End If
With Charts("plot")
'X axis name
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Speed (mm/s)"
'y-axis name
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Friction coefficient"
'Scale Axis
.Axes(xlCategory).ScaleType = xlLogarithmic
.Axes(xlCategory).MinimumScale = 4.5
.Axes(xlCategory).MaximumScale = 3500
End With
ActiveWorkbook.Save
End Sub
Thank you very much for any input on this problem.
Best regards,
Rikard
I'm not sure that converting to arrays will help all that much.
A quick win will be to switch off calculation for the entire process:
Application.Calculation = xlCalculationManual
Don't forget to switch it back on again once you're done.
You can also switch off screen updating: Application.ScreenUpdating = False, but that doesn't improve things too much normally.
That all said, there's nothing in your VBA that can't be done directly on a worksheet with the built-in Excel formulas. That's probably best in terms of performance.
i=19
With ListBox1
'clearing previous values from sheet
range(Cells(i + 2, 1).Address & ":" & Cells(endRwow, 7).Address).ClearContents
ListBoxArrSelected = vbNullString
For y = 0 To .ListCount - 1
If .Selected(y) Then
' concatenate all selected strings
ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
End If
Next y
' fill array with concatenated all selected strings spliting to rows
ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")
For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
' fill array with concatenated all selected strings spliting to colomuns
ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
For URc = 1 To UBound(ListBoxArrSplitToCell, 1) + 1
'paste to sheet
Cells(i + UR, 1).value = timeStr
Cells(i + UR, URc + 1).value = ListBoxArrSplitToCell(URc - 1)
Next URc
Next UR
End With
Then in listbox selected > 100 field excel responds very slow to copy them to worksheet
How to speed up this code?
You can reduce the number of cell writes using something like this:
i = 19
With ListBox1
Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents
ListBoxArrSelected = vbNullString
For y = 0 To .ListCount - 1
If .Selected(y) Then
ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
End If
Next y
ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")
Cells(i + 1, 1).Resize(UBound(ListBoxArrSplitToRows, 1) + 1).Value = timeStr
For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
Cells(i + UR, 2).Resize(, UBound(ListBoxArrSplitToCell, 1) + 1).Value = ListBoxArrSplitToCell
Next UR
End With
If you have the same number of delimited items in each row of the listbox, you could create an array of arrays and then output that to the sheet in one write operation. Code would be something like this:
Dim ListBoxArrSplitToRows()
Dim counter As Long
Dim columnCount As Long
i = 19
Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents
With ListBox1
ReDim ListBoxArrSplitToRows(.ListCount - 1)
For y = 1 To .ListCount
If .Selected(y - 1) Then
' load subarray into array
ListBoxArrSplitToRows(counter) = Split(.List(y - 1), "·")
counter = counter + 1
End If
Next y
End With
' resize array to used extent
ReDim Preserve ListBoxArrSplitToRows(counter - 1)
' get column count using first subarray
columnCount = UBound(ListBoxArrSplitToRows(0)) + 1
Cells(i + 1, "B").Resize(counter, columnCount).Value = Application.Index(ListBoxArrSplitToRows, 0, 0)
or just Cells(i + 1, "B").Resize(counter, columnCount).Value = ListBoxArrSplitToRows