I am trying to copy data (cca. 70*25*15 Cells) out of a txt file into libre office spreadsheet with a macro. Right now im accesing cells with this code :
Example:
Dim CellValue As Object
CellValue = ThisComponent.Sheets(1).getCellByPosition(i, j)
CellValue.String = "Whatever data i get from txt"
By running the above code and if text file have (70*25*15) cell entries, it needs 2min and 18 sec to copy all the data from text file to spreadsheet. Is there a better way to acess cells and speed up the process ?
You could set the DataArray of an object which implements XCellRangeData form an array of arrays.
Example:
Sub Test()
aDataArray = array(array("A1", "B1", "C1"), array("A2", 2.2, 2.3), array("A3", 3.2, 3.3))
oDoc = ThisComponent
oSheet = oDoc.getSheets().getByIndex(1)
oRange = oSheet.getCellRangeByName("A1:C3")
'xray oRange
oRange.setDataArray(aDataArray)
End Sub
https://www.openoffice.org/api/docs/common/ref/com/sun/star/sheet/XCellRangeData.html#setDataArray
Edit:
More complex example:
Sub Test()
lRowCount = 1800
lColCount = 40
dim aDataArray() as variant
dim aColumnArray() as variant
redim aDataArray(lRowCount-1) 'the main array is for rows; 0-based so count-1
for lRow = lbound(aDataArray) to ubound(aDataArray)
redim aColumnArray(lColCount-1) 'this array is for column data
for lCol = lbound(aColumnArray) to ubound(aColumnArray)
'create some sample data
select case lCol
case 1
aColumnArray(lCol) = CInt(int((10 * rnd()) + 1) 'integer in column 2
case 2
aColumnArray(lCol) = CDbl(1000 * rnd()) 'double in column 3, later formatted as currency
case 3
aColumnArray(lCol) = CDbl(date + int(365*rnd())) 'date in column 4, must be double in the array, will be later formatted as date
case 4
aColumnArray(lCol) = CInt(lRow mod 2 = 0) 'boolean in column 5, must be integer in the array, will be later formatted as booleann
case else
aColumnArray(lCol) = "r" & lRow & "c" & lCol 'all other columns string
end select
next
aDataArray(lRow) = aColumnArray
next
oDoc = ThisComponent
oSheet = oDoc.getSheets().getByIndex(0)
lStartRow = 1
lStartCol = 0
'make sure, the size of the range will exactly match the array size
oRange = oSheet.getCellRangeByPosition(lStartCol, lStartRow, lStartCol+lColCount-1, lStartRow+lRowCount-1)
oRange.setDataArray(aDataArray) 'now the data is in the sheet
'this code is for formatting
oLocale = new com.sun.star.lang.Locale 'create empty locale
oNumberFormats = thiscomponent.getNumberFormats() 'get NumberFormats from Calc
'format column 3 as currency
oRange = oSheet.getCellRangeByPosition(2, lStartRow, 2, lStartRow+lRowCount-1)
lCurrencyFormat = oNumberFormats.getStandardFormat(com.sun.star.util.NumberFormat.CURRENCY, oLocale)
oRange.NumberFormat = lCurrencyFormat
'format column 4 as date
oRange = oSheet.getCellRangeByPosition(3, lStartRow, 3, lStartRow+lRowCount-1)
lFormat = oNumberFormats.getStandardFormat(com.sun.star.util.NumberFormat.DATE, oLocale)
oRange.NumberFormat = lFormat
'format column 5 as boolean
oRange = oSheet.getCellRangeByPosition(4, lStartRow, 4, lStartRow+lRowCount-1)
lFormat = oNumberFormats.getStandardFormat(com.sun.star.util.NumberFormat.LOGICAL, oLocale)
oRange.NumberFormat = lFormat
End Sub
Related
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
The following code reads lines from a csv file and reformats row headings. I hope I can articulate this, but I'd like to format cells to two decimals in rows below headings in which the vct_FEMAP_Results() function returns a value.
Example:
ID "CSys ID" "Set ID" Plate Top VM Stress Plate Bot VM Stress
------ ----------- ---------- ----------------------- ----------------------
4591 0 20 229.9488 244.8103
4592 0 20 323.5026 315.1129
I'm trying to format the cells containing the decimals without affecting the data in column headings ID, CSys ID, or Set ID. The code below formats all columns to 2 decimals. Not sure why.
Sub cmdOpen_Click()
Dim wrdArray() As String, txtstrm As TextStream, line As String
Dim wrd As Variant, myWrd As String
Dim col As Long, colCount As Long
Dim count As Long
Dim row As Long, temp As Long
Dim str As String, regex As RegExp
Dim matches As MatchCollection, lineMatch As match, wrdMatch As match
Dim i As Long, j As Long, x As Long
Dim strPath As String, strLine As String
Set regex = New RegExp
regex.Pattern = "\d+"
regex.Global = True
'Remove Filters and Add Custom Filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Text Files", "*.txt")
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Dat Files", "*.dat")
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Comma Delimited Files", "*.csv")
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End If
'------------------------------------------------------------
If strPath <> "" Then
Set txtstrm = FSO.OpenTextFile(strPath)
Else
Exit Sub
End If
row = 1
Do Until txtstrm.AtEndOfStream
line = txtstrm.ReadLine
x = 1
col = 1
count = 0
wrdArray() = Split(line, ",")
For Each wrd In wrdArray()
count = count + 1
myWrd = wrd
ActiveSheet.Cells(row, col) = wrd
col = col + 1
Next wrd
If (row = 1) Then
For i = 0 To count - 1
Set matches = regex.Execute(wrdArray(i))
For Each wrdMatch In matches
If wrdMatch Then
ActiveSheet.Cells(1, i + 1) = vct_FEMAP_Results(wrdMatch.Value)
x = x + 1
End If
Next
Next i
End If
row = row + 1
Loop
txtstrm.Close
For i = 1 To row - 1
For j = x To col - 1
ActiveSheet.Cells(i, j).NumberFormat = "0.00"
Next j
Next i
End Sub
Your code is formatting all your columns because you are looping through the columns with this bit:
For i = 1 To row - 1
For j = x To col - 1
ActiveSheet.Cells(i, j).NumberFormat = "0.00"
Next j
Next i
If you already know which columns need to be formatted, just do it like this:
ActiveSheet.Range("d:d, e:e").EntireColumn.NumberFormat = "0.00"
That will reformat only columns D and E, as per your sample data. Change the d's and e's if you need other columns.
I actually prefer to avoid using "ActiveSheet" and always reference the specific worksheet explicitly, so I'm always sure which worksheet my code is targeting. Whereas, when you use ActiveSheet(or cell or workbook) the active sheet can change, sometimes in unexpected ways.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("d:d, e:e").EntireColumn.NumberFormat = "0.00"
I hope that helps!
The script fills an array from a sheet called "Tigers" with 6 strings. Then it is supposed to compare that array to a differnt sheet titled "Elephants" and tell me if it finds an exact match. The troublesome code is found at the Application.Match method
Any help understanding how to correctly script a match with multiple values would be appreciated.
Sub matchData()
Dim arrCompare(5) As Variant
Dim intRow As Integer
Dim varRes As Variant
Set sht = ActiveSheet
Set shtTigers = Worksheets("Tigers").Range("A2:A100")
Set shtElephants = Worksheets("Elephants").Range("A2:A100")
Sheets("Elephants").Activate
For intRow = 2 To 100
arrCompare(0) = Worksheets("Elephants").Cells(intRow, 1).Value
arrCompare(1) = Worksheets("Elephants").Cells(intRow, 2).Value
arrCompare(2) = Worksheets("Elephants").Cells(intRow, 4).Value
arrCompare(3) = Worksheets("Elephants").Cells(intRow, 5).Value
arrCompare(4) = Worksheets("Elephants").Cells(intRow, 7).Value
arrCompare(5) = Worksheets("Elephants").Cells(intRow, 9).Value
'compare all 6 strings in array against Elephant sheet rows for a match
varRes = Application.Match(arrCompare(), shtTigers, 0)
'also tried
'varRes = Application.Match(((arrCompare(0))*((arrCompare(1))*((arrCompare(2)) * ((arrCompare(3)) * ((arrCompare(4)) * ((arrCompare(5))*((arrCompare(6)),shtTigers, 0)
'messagebox just gives a Error 13 or 2042 for varRes
MsgBox ("varRes = " & varRes)
Next
End Sub
Match requires a single lookup value but you're trying to pass the whole array. Iterate one element at at time instead:
Dim counter as Integer
For x = 0 to 5
If Not IsError(Application.Match(arrCompare(x), shtTigers, 0)) Then
counter = counter + 1
End If
Next x
If counter = 6 Then Debug.Print "Matches found"
Lets say I have a database of words in Sheet2; it goes from A1 to B200.
I need to randomly select one of those words; and show it in Sheet1.
Moreover, I need to have on blank cell between each letter of the word.
Example: The randomly selected word is COLD; it has to appear like this:
A1: C
A3: O
A5: L
A7: D
How can I code this?
try this code:
Option Explicit
Sub main()
Dim word As String
word = GetRandomWord(Worksheets("Sheet2").Range("A1:B200")) '<--| get content of a random cell in passed range
Worksheets("Sheet1").Range("a1").Resize(2 * Len(word) - 1).Value = Application.Transpose(SeparatedChars(word)) '<--| write it down from given worksheet cell A1 down skipping every two cells
End Sub
Function SeparatedChars(strng As String) As Variant
Dim i As Long
ReDim chars(0 To Len(strng) - 1) As String '<--| size a 'String' array to the length of passed word
For i = 1 To Len(strng)
chars(i - 1) = Mid$(strng, i, 1) '<--| fill array elements with word single characters
Next
SeparatedChars = Split(Join(chars, " "), " ") '<--| return an array whose elements are those of the 'String' array and interposed spaces
End Function
Function GetRandomWord(rng As Range) As String
Randomize
GetRandomWord = rng.Cells(Int((rng.Count) * Rnd() + 1)).Text
End Function
Assuming the words are written in column A of sheet2 you could do the following (part of this solution comes from here:
Sub randomWord()
Dim rndWordRow As Integer
Dim arr() As String
Dim buff() As String
'Select row between 1 and 200 randomly'
rndWordRow = Int((200 - 1 + 1) * Rnd + 1)
'Write text of the randomly selected row into variable'
rndWord = Sheets("Sheet2").Cells(rndWordRow, 1)
'Write letters of text into array'
ReDim buff(Len(rndWord) - 1)
For i = 1 To Len(rndWord)
buff(i - 1) = Mid$(rndWord, i, 1)
Next
'Loop through array and write letters in single cells'
For i = 0 To UBound(buff)
Sheets("Sheet1").Cells(i + 1, 1) = buff(i)
Next i
End Sub
Sub Test()
Dim x As Long
Dim aWord
With Worksheets("Sheet1")
For x = 1 To 15
aWord = getRandomWord
.Cells(1, x).Resize(UBound(aWord)).value = aWord
Next
End With
End Sub
Function getRandomWord()
Dim Source As Range
Dim result
Dim i As Integer
Set Source = Worksheets("Sheet2").Range("A1:B200")
i = Int((Rnd * Source.Cells.Count) + 1)
result = StrConv(Source.Cells(i).Text, vbUnicode)
result = Split(Left(result, Len(result) - 1), vbNullChar)
getRandomWord = Application.Transpose(result)
End Function
Here's a simple solution to your problem. This routine gives you a blank cell between two letters with the first letter in the first cell.
R1 = Int(Rnd() * 200)
R2 = Int(Rnd() * 2)
anyword = Sheet2.Cells(R1, R2)
x = Len(anyword)
n = -1: i = 1
Do
n = n + 2
Sheet1.Cells(n, 1) = Mid(anyword, i, 1)
i = i + 1
Loop Until n > x * 2
HI I am trying to search for a sub string within a string and if the sub string is found then I want to paste the output to my spreadsheet. I am using th InStr function with a conditional statement <> , so that if mt InStr function value is not equal to 0 I know I have a match. I do not get any errors when I run the code but it does not display the result on the sheet. SOS!! :)
Sub unicornhorn()
'Generates user friendly graphs from raw unicorn input data
Dim columns As Integer
Dim rows As Integer
Dim Outputs(50) As String
Dim LastRow As Integer
Dim StrG As Integer
Dim xaxis As Range
Dim yaxis As Range
Dim nLeft As Double: nLeft = 20
Dim nTop As Double: nTop = 20
Dim start As Double: start = start + 2
Dim finish As Double: finish = finish + 2
Dim Curves(14) As String
Curves(0) = "260nm"
Curves(1) = "280nm"
Curves(2) = "214nm"
Curves(3) = "Cond"
Curves(4) = "Cond%"
Curves(5) = "Conc"
Curves(6) = "pH"
Curves(7) = "Pressure"
Curves(8) = "Flow"
Curves(9) = "Temp"
Curves(10) = "Fractions"
Curves(11) = "inject"
Curves(12) = "logbook"
Curves(13) = "P960_Press"
Curves(14) = "P960_Flow"
Dim D As Worksheet
Set D = Worksheets("DATA")
Dim C As Worksheet
Set C = Worksheets("sheet1")
'defines data range
columns = shCurves.Cells(1, shCurves.columns.Count).End(xlToLeft).Column
'XXreturn check to sheet
ShData.Cells(5, 5).Value = columns
rows = shCurves.Cells(shCurves.rows.Count, 1).End(xlUp).Row
'XXreturn check to sheet
ShData.Cells(5, 6).Value = rows
For Z = 0 To columns
'loops through array for different curves
Outputs(Z) = shCurves.Cells(2, Z * 2 + 1).Value
'XXreturn check to sheet
ShData.Cells(5 + Z, 7).Value = Outputs(Z)
'Finds last row in column for current curve
LastRow = Cells(D.rows.Count, Z * 2 + 1).End(xlUp).Row
For k = 0 To 14
'finds curve identifyer within string
StrG = InStr("Outputs(Z)", "Curves(k)")
If StrG <> 0 Then
ShData.Cells(25 + k, 5).Value = Curves(k)
Exit For
End If
Next k
Next Z
End Sub
Why do you have double quotes around your arrays?
StrG = InStr("Outputs(Z)", "Curves(k)")
You're using the string literals, not the variables. Remove the double quotes:
StrG = InStr(Outputs(Z), Curves(k))