I have two textboxes on a form; one hold the word and the other one holds its numeric value that is calculated based on what the user types. I have a sub that separates each sentence and displays the total for each sentence in Excel. This is the output that being generated from the vb.net code which is listed below. All the words are in A column and all the values in B column. How do I modify the code so it inserts each sentence and its value in two columns? After it reaches the string "Total for sentence 1." it should start inserting the words and its values in columns C & D and so forth.
Sentence one and its value should be displayed in columns A & B, sentence two and its value should be displayed in columns C & D and so on.
Please see the attached image. Text in red is what I currently have and below it is the desired result. Thanks!
My Code in vb.net is:
Private Sub Export_Click(sender As System.Object, e As System.EventArgs) Handles btnCreate.Click
xlWorkBook = xlApp.Workbooks.Add
xlApp.Visible = True
xlWorkSheet = xlWorkBook.Sheets("Sheet1")
Dim columnANum As Integer
Dim columnBNum
columnBNum = 2
columnANum = 2
With xlWorkSheet
.Range("A1").Value = "Word"
For Each cellA As String In txtWord.Text.Split(vbLf)
.Range("A" & columnANum.ToString).Value = cellA
columnANum += 1
Next
.Range("B1").Value = "Value"
For Each cellB As String In txtValue.Text.Split(vbLf)
.Range("B" & columnBNum.ToString).Value = Convert.ToInt32(cellB)
columnBNum += 1
Next
End With
End Sub
EDIT: I made significant changes to this code and tested it; it should do what you're looking for
Sub testExcelColumns()
Dim xlApp As Object = CreateObject("Excel.Application")
Dim xlWorkBook As Object
Dim xlWorkSheet As Object
xlWorkBook = xlApp.Workbooks.Add
xlApp.Visible = True
xlWorkSheet = xlWorkBook.Sheets("Sheet1")
Dim RowNum As Integer = 1
Dim ColNum As Integer = 1
'use .cells(row, column) instead of .range
xlWorkSheet.cells(RowNum, ColNum).Value = "Word"
For Each cellA As String In txtWord.Text.Split(vbLf)
'increment the row
RowNum += 1
'set the value
xlWorkSheet.cells(RowNum, ColNum).value = cellA
If cellA.StartsWith("Total") Then
ColNum += 2
RowNum = 1
xlWorkSheet.cells(RowNum, ColNum).Value = "Word"
End If
Next
'increment to the second column and first row
ColNum = 2
RowNum = 1
'set title
xlWorkSheet.cells(RowNum, ColNum).Value = "Value"
For Each cellB As String In txtValue.Text.Split(vbLf)
'increment the row
RowNum += 1
'set the value
xlWorkSheet.cells(RowNum, ColNum).value = cellB
'get value of cell to the left
Dim t As String = xlWorkSheet.cells(RowNum, ColNum).offset(0, -1).value
If Not t Is Nothing AndAlso t.StartsWith("Total") Then
ColNum += 2
RowNum = 1
xlWorkSheet.cells(RowNum, ColNum).Value = "Value"
End If
Next
End Sub
Try using
Dim RowNum as Integer = 1
Dim ColNum as Integer = 1
use .cells instead of .range
xlWorkSheet.Cells(RowNum, ColNum).value = "Word"
xlWorkSheet.Cells(RowNum, ColNum).value = "Value"
update the row and column as needed
RowNum += 1
ColNum += 1
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!
I am working on some data from which I want to extract unique values from a column and storing them in an array and later using it for other calculations.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([E1], Cells(Rows.Count, "E").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("K1:K" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
The Data set is found here.
Now I want the code to take the input using an input box which column to search([E1] here) for unique values and where the output is stored ("K1:K" here).
Add the InputBox code with a variable to hold its value:
Dim col As String
Dim output_col As String
col = InputBox("Type the column letter to search in", "Data Input")
output_col = InputBox("Type the column letter to write results to", "Data Input")
And add some logic, e.g., if the column letter length is not 0, process.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Dim col As String
Dim output_col As String
col = InputBox("Type the column letter to search in", "Data Input")
output_col = InputBox("Type the column letter to write results to", "Data Input")
If Len(col) > 0 And Len(output_col) > 0 Then
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range(col & CStr(1), Cells(Rows.Count, col).End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range(output_col & CStr(1) & ":" & output_col & objDict.Count) = Application.Transpose(objDict.keys)
End If
End Sub
I have a simple piece of code written which basically scans through column A, detects for a condition and once the condition is met in a row, it copies the cell in column B of the same row into an array. I was hoping someone could help me make a nested array which would not only store the value in column B but also its rowcount. here is what i have so far, any help is appreciated.
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim ii As Integer
ii = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
Dim oldarray() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim oldvalue As Range
ReDim Preserve oldarray(ii)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
oldarray(ii) = oldvalue.Value
ii = ii + 1
End If
End If
Next
You need a two dimensional array. Use one dimension for the value and the other for the row. Here's an example
Sub GetArray()
Dim vaInput As Variant
Dim rRng As Range
Dim aOutput() As Variant
Dim i As Long
Dim lCnt As Long
'Define the range to test
Set rRng = DataSheet.Range("A1", DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp)).Resize(, 2)
'Put the values in that range into an array
vaInput = rRng.Value
'Lopo through the array
For i = LBound(vaInput, 1) To UBound(vaInput, 1)
'Skip blank cells
If Len(vaInput(i, 1)) > 0 Then
'Test for the sheet's name in the value
If Split(vaInput(i, 1), "$")(0) = DHRSheet.Name Then
'Write the value and row to the output array
lCnt = lCnt + 1
'You can only adjust the second dimension with a redim preserve
ReDim Preserve aOutput(1 To 2, 1 To lCnt)
aOutput(1, lCnt) = vaInput(i, 2) 'write the value
aOutput(2, lCnt) = i 'write the row count
End If
End If
Next i
'Output to see if you got it right
For i = LBound(aOutput, 2) To UBound(aOutput, 2)
Debug.Print aOutput(1, i), aOutput(2, i)
Next i
End Sub
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim arr() As Variant
Dim p As Integer
p = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim subarr(1) As Variant
Dim oldvalue As Range
ReDim Preserve arr(p)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
subarr(0) = oldvalue.Value
subarr(1) = cell2.Row
arr(p) = subarr
p = p + 1
'MsgBox (oldvalue)
End If
End If
Next
I currently have an array which I populate and paste in a sheet named "T1" using a macro. My current macro uses the rowcount function to determine the used rows and pastes the array from the next available row.
The problem I am having is that when I paste this array multiple times, the arrays need to be spaced by a row so that i can differentiate different submissions. This is what I have so far, and I was hoping someone could help me with this:
Sub CopyData()
Dim Truearray() As String
Dim cell As Excel.Range
Dim RowCount1 As Integer
Dim i As Integer
Dim ii As Integer
Dim col As Range
Dim col2 As Range
i = 0
ii = 2
RowCount1 = DHRSheet.UsedRange.Rows.Count
Set col = DHRSheet.Range("I1:I" & RowCount1)
For Each cell In col
If cell.Value = "True" Then
Dim ValueCell As Range
Set ValueCell = Cells(cell.Row, 3)
ReDim Preserve Truearray(i)
Truearray(i) = ValueCell.Value
Dim siblingCell As Range
Set siblingCell = Cells(cell.Row, 2)
Dim Siblingarray() As String
ReDim Preserve Siblingarray(i)
Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value
i = i + 1
End If
Next
Dim RowCount2 As Integer
RowCount2 = DataSheet.UsedRange.Rows.Count + 1
For ii = 2 To UBound(Truearray)
DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
Next
For ii = 2 To UBound(Siblingarray)
DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
Next
DataSheet.Columns("A:B").AutoFit
MsgBox ("Data entered has been successfully validated & logged")
End Sub
If you Offset two rows from the bottom cell, you will leave a blank row of separation. You should also consider filling the whole array as base 1 and writing it to DataSheet in one shot.
Sub CopyData2()
Dim rCell As Range
Dim aTrues() As Variant
Dim rRng As Range
Dim lCnt As Long
'Define the range to search
With DHRSheet
Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
End With
'resize array to hold all the 'trues'
ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)
For Each rCell In rRng.Cells
If rCell.Value = "True" Then
lCnt = lCnt + 1
'store the string from column 2
aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
'store the value from column 3
aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
End If
Next rCell
'offset 2 from the bottom row to leave a row of separation
With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
'write the stored information at one time
.Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
End With
End Sub