i am writing a code to transfer list box data to new excel workbook. it is working by populating new worksheet from row 2 and particular column. what i want is, list should be populating from row 23 in particular column. i have tried to search but unable to make it work. my code is as below,
Private Sub cmdprint_Click()
Dim xl As New Excel.Application
Dim xlwbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
xl.DisplayAlerts = False
Set xlwbook = xl.Workbooks.Open("C:\Users\filename.xlsm")
Set xlsheet = xlwbook.Sheets.Item("output")
Dim i As Long, j As Long
j = 2
With UserForm1.lstdatabase1
For i = 0 To UserForm1.lstdatabase1.ListCount - 1
With xlsheet
.Cells(j, 7).End(xlUp).Offset(1).Value = UserForm1.lstdatabase1.List(i, 1) 'column 1
.Cells(j, 8).End(xlUp).Offset(1).Value = UserForm1.lstdatabase1.List(i, 2) 'column 2
j = j + 1
End With
xlwbook.SaveAs ("C:\Users\File name (i want this to be value from userform text box")
xl.DisplayAlerts = True
'no need to carry on searching
Next i
End With
End Sub
Also, i would like to save file save as Textbox value from form, instead of fix name.
can you pl help me with that.
thanks
Try
Private Sub cmdprint_Click()
Dim xl As New Excel.Application
Dim xlwbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
xl.DisplayAlerts = False
Set xlwbook = xl.Workbooks.Open("C:\Users\filename.xlsm")
Set xlsheet = xlwbook.Sheets.Item("output")
Dim i As Long , j As Long
j = 23
With UserForm1.lstdatabase1
For i = 0 To UserForm1.lstdatabase1.ListCount - 1
With xlsheet
.Cells(j, 7).Value = UserForm1.lstdatabase1.List(i, 1) 'column 1
.Cells(j, 8).Value = UserForm1.lstdatabase1.List(i, 2) 'column 2
j = j + 1
End With
xlwbook.SaveAs ("C:\Users\File name (i want this to be value from userform text box")
xl.DisplayAlerts = True
'no need to carry on searching
Next i
End With
Related
I am running into an issue while trying to export a Datagridview to an excel workbook. I have 2 different codes, the first one throws an error about a null value and the second exports the data to excel but its missing the headers and a column or 2. Any direction you can give would be mush appreciated.
This one throws a Null Error
'Creating DataTable
Dim dt As New DataTable()
'Adding the Columns
For Each column As DataGridViewColumn In DataGridView1.Columns
dt.Columns.Add(column.HeaderText, column.ValueType)
Next
'Adding the Rows
For Each row As DataGridViewRow In DataGridView1.Rows
dt.Rows.Add()
For Each cell As DataGridViewCell In row.Cells
dt.Rows(dt.Rows.Count - 1)(cell.ColumnIndex) = cell.Value.ToString()
Next
Next
'Exporting to Excel
Dim folderPath As String = "C:\Users\" & UserName & "\Desktop\SkyNet Exports"
If Not My.Computer.FileSystem.DirectoryExists(folderPath) Then
My.Computer.FileSystem.CreateDirectory(folderPath)
End If
Dim wb As New Excel.Application()
wb.Worksheets.Add(dt, "Skills")
wb.SaveAs(folderPath & Convert.ToString("SkyNet Export.xlsx"))
And this one exports to excel but with missing columns and no headers
Private Sub ExportToExcel()
Dim ExcelApp As Object, ExcelBook As Object
Dim ExcelSheet As Object
Dim i As Integer
Dim j As Integer
'create object of excel
ExcelApp = CreateObject("Excel.Application")
ExcelBook = ExcelApp.WorkBooks.Add
ExcelSheet = ExcelBook.WorkSheets(1)
With ExcelSheet
For i = 1 To Me.DataGridView1.RowCount
.cells(i, 1) = Me.DataGridView1.Rows(i - 1).Cells("id").Value
For j = 1 To DataGridView1.Columns.Count - 1
.cells(i, j + 1) = DataGridView1.Rows(i - 1).Cells(j).Value
Next
Next
End With
ExcelApp.Visible = True
'
ExcelSheet = Nothing
ExcelBook = Nothing
ExcelApp = Nothing
End Sub
Once again any help is appreciated, I have looked at different sites but most are not using VB.Net
Here is the error for the first code
Code Error
In 1st Code , you need to try following changes (Header text should not be duplicate in datagridview, It is better to add columnname in your datatable )
'Adding the Columns
For Each column As DataGridViewColumn In DataGridView1.Columns
dt.Columns.Add(column.Name, column.ValueType)
Next
'Adding the Rows
dim dr as datarow
For Each row As DataGridViewRow In DataGridView1.Rows
dr = dt.Newrow
For Each cell As DataGridViewCell In row.Cells
If not isnothing(cell.value) then
dr(datagridview1.columns(cell.ColumnIndex).Name)= cell.Value
End if
Next
dt.rows.add (dr)
Next
In 2nd code you miss to add headers and also while your try to get column values you started your j iterator with 1 so value at 1st column will be missing (if your id column is not a 1st column)
Private Sub ExportToExcel()
Dim ExcelApp As Object, ExcelBook As Object
Dim ExcelSheet As Object
Dim i As Integer
Dim j As Integer
'create object of excel
ExcelApp = CreateObject("Excel.Application")
ExcelBook = ExcelApp.WorkBooks.Add
ExcelSheet = ExcelBook.WorkSheets(1)
dim rowIndex as integer = 1
dim colIndex as integer = 2
''For Headers
With ExcelSheet
For each column as datagridviewcolumn in Me.DataGridView1.columns
if column.name = "Id" then
.cells(rowindex, 1) = Column.HeaderText
else
.cells(rowindex, colIndex) = Column.HeaderText
colIndex = ColIndex + 1
end if
Next
End With
With ExcelSheet
For i = 0 To Me.DataGridView1.RowCount-1
if not isnothing (Me.DataGridView1.Rows(i).Cells(0).value) then
rowindex = rowIndex + 1
ColumnIndex = 2
For j = 0 To DataGridView1.Columns.Count - 1
if datagridview1.columns(j).name = "Id" then
.cells(rowindex, 1) = DataGridView1.Rows(i).Cells(j).Value
else
.cells(rowindex, columnIndex ) = DataGridView1.Rows(i).Cells(j).Value
ColumnIndex = ColumnIndex + 1
End if
Next
End if
Next
End With
ExcelApp.Visible = True
'
ExcelSheet = Nothing
ExcelBook = Nothing
ExcelApp = Nothing
End Sub
I went with the 2nd code. I tried to use your code and it didnt work at first but then I noticed you had named the column index as ColumnIndex, and it was actually needed to be names colIndex, Thanks for all your help.
Here is the finished code,
Private Sub ExportToExcel()
Dim ExcelApp As Object, ExcelBook As Object
Dim ExcelSheet As Object
Dim i As Integer
Dim j As Integer
'create object of excel
ExcelApp = CreateObject("Excel.Application")
ExcelBook = ExcelApp.WorkBooks.Add
ExcelSheet = ExcelBook.WorkSheets(1)
Dim rowIndex As Integer = 1
Dim colIndex As Integer = 1
''For Headers
With ExcelSheet
For Each column As DataGridViewColumn In Me.DataGridView1.Columns
If column.Name = "Id" Then
.cells(rowIndex, 1) = column.HeaderText
Else
.cells(rowIndex, colIndex) = column.HeaderText
colIndex = colIndex + 1
End If
Next
End With
''For Rows
With ExcelSheet
For i = 0 To Me.DataGridView1.RowCount - 1
If Not IsNothing(Me.DataGridView1.Rows(i).Cells(0).Value) Then
rowIndex = rowIndex + 1
colIndex = 1
For j = 0 To DataGridView1.Columns.Count - 1
If DataGridView1.Columns(j).Name = "Id" Then
.cells(rowIndex, 1) = DataGridView1.Rows(i).Cells(j).Value
Else
.cells(rowIndex, colIndex) = DataGridView1.Rows(i).Cells(j).Value
colIndex = colIndex + 1
End If
Next
End If
Next
End With
ExcelApp.Visible = True
'
ExcelSheet = Nothing
ExcelBook = Nothing
ExcelApp = Nothing
End Sub
```
I am populating ActiveX control labels with a subset of Excel data in VBA. My code previously worked for the entire Excel workbook, but once I changed my code to only reference a subset of the data, the incorrect data is being entered.
Here is a snapshot of example data. In my code, Column 6= CY and Column 7 = FY. The code is currently populating my labels with the headers of Column 6 and 7 rather than the values of 'active' or 'merged' projects.
As mentioned, I am not receiving any error messages, but the correct data is not being added to my ActiveX labels. FYI... In line 31 Code1 is the name of an ActiveX label.
Private Sub CommandButton1_Click()
Dim objExcel As Excel.Application
Dim exWB As Excel.Workbook
Dim rng As Excel.Range, m, rw As Excel.Range
Dim num, TableNo, seq As Integer
Dim ctl As MSForms.Label
Dim ils As Word.InlineShape
Dim rngrow As Excel.Range
Dim active As Excel.Range
Set objExcel = New Excel.Application
TableNo = ActiveDocument.Tables.Count
num = 3
seq = 1
Set exWB = objExcel.Workbooks.Open("O:\Documents\"Database.csv")
Set rng = exWB.Sheets("Sheet1").Cells
''''Select active projects as subset
For Each rngrow In rng.Range("A1:L144")
If rngrow.Columns(8).value = "Active" Or rngrow.Columns(8).value = "Merged" Then
If active Is Nothing Then
Set active = rngrow
Else
Set active = Union(active, rngrow)
End If
End If
Next rngrow
m = objExcel.Match(ActiveDocument.Code1.Caption, active.Columns(3), 0)
'' Now, create all ActiveX FY labels and populate with FY Use
Do
Set ils = ActiveDocument.Tables(num).cell(6, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = "FY" & seq
If Not IsError(m) Then
Set rw = rng.Rows(m)
ctl.Caption = rw.Cells(7).value
Else
MsgBox "No match found"
End If
seq = seq + 1
num = num + 1
Loop Until num = TableNo + 1
'' Now, create all ActiveX CY labels and populate with CY
num = 3
seq = 1
Do
Set ils = ActiveDocument.Tables(num).cell(7, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = "CY" & seq
If Not IsError(m) Then
Set rw = rng.Rows(m)
ctl.Caption = rw.Cells(6).value
Else
MsgBox "No match found"
End If
seq = seq + 1
num = num + 1
Loop Until num = TableNo + 1
Set exWB = Nothing
End Sub
Link to my previous question below:
Using Excel data to create Word Doc caption labels in VBA
This:
For Each rngrow In rng.Range("A1:L144")
will be interpreted as
For Each rngrow In rng.Range("A1:L144").Cells
so your loop will be A1, B1, C1, ... L1 then A2, B2 etc.
It seems like you meant it to be:
For Each rngrow In rng.Range("A1:L144").Rows
so rngRow will be A1:L1, then A2:L2, etc.
EDIT - You can't refer to active using something like MsgBox(active.Range ("A2")), since it's a multi-area range.
Try this for example -
For Each rw in active.Rows
debug.print "Row:" & rw.Row, rw.cells(8).value
Next rw
EDIT2: try this instead. Untested but I think it should work OK
Private Sub CommandButton1_Click()
Dim objExcel As Excel.Application
Dim exWB As Excel.Workbook
Dim data, r As Long, resRow As Long, seq As Long, num As Long
Dim doc As Document
'get the Excel data as a 2D array
Set objExcel = New Excel.Application
Set exWB = objExcel.Workbooks.Open("O:\Documents\Database.csv")
data = exWB.Sheets("Sheet1").Range("A1:L144").Value '>> 2D array
exWB.Close False
objExcel.Quit
resRow = 0
'find the first matching row, if any
For r = 1 To UBound(data, 1)
If (data(r, 8) = "Active" Or data(r, 8) = "Merged") And _
data(r, 3) = doc.Code1.Caption Then
resRow = r 'this is the row we want
Exit Sub 'done looking
End If
Next r
Set doc = ActiveDocument
seq = 1
For num = 3 To doc.Tables.Count
With doc.Tables(num)
AddLabel .Cell(6, 2), "FY" & seq, IIf(resRow > 0, data(resRow, 7), "Not found")
AddLabel .Cell(7, 2), "CY" & seq, IIf(resRow > 0, data(resRow, 6), "Not found")
End With
seq = seq + 1
Next num
End Sub
'add a label to a cell, set its name and caption
Sub AddLabel(theCell As Cell, theName As String, theCaption As String)
Dim ils As InlineShape, ctl As MSForms.Label
Set ils = theCell.Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = theName
ctl.Caption = theCaption
End Sub
I want a user to press a button to pull all their "Open" positions into a userform.
I have a Userform with a Frame and a command button to search through Column 3 (named "Status") on a spreadsheet and find the word "Open". Once this word is found I want textboxes to be automatically created inside the frame with the data from the "found" row for columns 4 - 10.
So if one row is found with "Open" then I expect 7 textboxes to be created on the userform. From the picture below I expect 28 textboxes.
When I press the command button nothing happens - no errors - nothing. I tried to use the breakpoints to troubleshoot but nothing was revealed to me to take action on. I am not "seeing" why it is not working here.
I tried moving the code outside the userform and into a module and calling the function but that didn't do anything.
I tried setting the rows I want as constants and creating a separate "AddBox" function to call within the main code but that didn't work but I also didn't understand that code as much as I do the one I am posting now.
Frame Name = Open_Positions_Frame
Command Button Name = open_post_but
Sheet Name = Database
Public Sub open_post_but_Click() '*****The command Button on the userform Frame*****
Dim i As Integer ' for the loop
Dim wb As Workbook
Dim wk As Worksheet
Dim ctlTextBox As MSForms.TextBox
Dim intCol, intCols As Integer '******for the columns I want to pull into the userform*****
Dim strCName As String '******this is to name the textboxes******
Dim lastRow As Long
Dim curColumn As Long
Set wb = ThisWorkbook
Set wk = wb.Sheets("Database")
curColumn = 3 '*********column index here - Mine starts at Column 3 ********
lastRow = wk.Cells(Rows.Count, curColumn).End(xlUp).row
For i = 3 To lastRow 'Loop through row 3 to last row
'********If the text "Open" is found in a row in column 3 then
' add & fill textboxes with data from Columns 4-10 onto the userform frame******
If wk.Cells(i, 3) = "Open" Then
'******Add the textboxes***********
'*****Columns 4-10 add textbox and give the control a name C# - #is the column*****
For intCol = 4 To intCols = 10
strCName = "C" & intCol
Set ctlTextBox = Open_Positions_Frame.Controls.Add("Forms.Textbox.1", strCName)
With ctlTextBox
.Top = 10
.width = 50
.height = 20
.Left = (intCol) * 60
.Value = intCol
End With
Next
'********************************
End If
Next i
End Sub
UPDATED and TESTED
You were writing the text boxes on top of each other. i added a separater by row.
Public Sub open_post_but_Click()
'you might want to experiment with these.
Const curColumn As Long = 4 'index will start a column 4 "Status"
Const theWidth As Long = 66 'you might experiment with these
Const theRowDifference As Long = 20
Dim i As Long, intCol As Long, rowspacer As Long
Dim ctlTextBox As MSForms.TextBox
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wk As Worksheet: Set wk = wb.Sheets("Database")
Dim lastRow As Long: lastRow = wk.Cells(Rows.Count, curColumn).End(xlUp).row
For i = 3 To lastRow
For Each cl In wk.Cells(3, curColumn)
If InStr(1, cl.Value, "Open", vbTextCompare) > 0 Then
rowspacer = rowspacer + theRowDifference
'******Add the textboxes***********
For intCol = 5 To 11
Set ctlTextBox = Open_Positions_Frame.Controls.Add("Forms.Textbox.1")
With ctlTextBox
.Top = rowspacer
.width = theWidth
.height = 20
.Left = intCol * 60
.Name = "openPosBox" & intCol
.Value = wk.Cells(i, intCol).Value
End With
Next intCol
'********************************
End If
Next cl
Next i
End Sub
PGSystemTester helped figure out the stacking textbox issues - Huge thank you! However, I was still struggling with my If Condition statement. I managed to figure it out and I am adding the complete code as an answer for anyone needing this use case
Public Sub open_post_but_Click()
Const curColumn As Long = 4 'index will start a column 4 "Status"
Const theWidth As Long = 70 'you might experiment with these
Const theRowDifference As Long = 20
Dim i As Long, intCol As Long, rowspacer As Long
Dim ctlTextBox As MSForms.TextBox
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wk As Worksheet: Set wk = wb.Sheets("Database")
Dim lastRow As Long: lastRow = wk.Cells(Rows.Count, curColumn).End(xlUp).row
Dim status As String
status = "Open"
For i = 3 To lastRow
If Cells(i, curColumn).Value = status Then 'took on the Instr() function and added this instead, textboxes will only be created if the column 4 status is "Open"
rowspacer = rowspacer + theRowDifference
'******Add the textboxes***********
For intCol = 4 To 11
Set ctlTextBox = Open_Positions_Frame.Controls.Add("Forms.Textbox.1")
With ctlTextBox
.Top = rowspacer
.width = theWidth
.height = 20
.Left = intCol * 40
.Name = "openPosBox" & intCol
.Value = wk.Cells(i, intCol).Value
End With
Next intCol
'********************************
End If
Next i
End Sub
I am trying to create a Dropdown menu in Excel using VBA. When you select an item on the Dropdown menu, it should take a named range in the Workbook and insert it in a range below. I want to do this so I can compare various ranges.
I am unsure how to tackle this, this is what I've tried so far:
Function Compare()
Dim variable1 As String
Dim variable2 As String
Dim dd1 As DropDown
Dim dd2 As DropDown
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Compare")
Set dd1 = ActiveSheet.DropDowns("dropdown1")
Set dd2 = ActiveSheet.DropDowns("dropdown2")
Set r1 = ws.Range(dd1.ListFillRange)
Set r2 = ws.Range(dd2.ListFillRange)
Set variable1 = r1(dd1.Value)
Set variable2 = r2(dd2.Value)
If variable1 = "Example 1" Then
wb.ws.Range("h12:j58").Value = Range("ap_ks")
End If
End Function
I've managed to do it with an IF statement, but only for 1 of the items so far. Doing it for all items would make the formula very large, so instead I am trying to do it in VBA.
{=IFS(D8=Overview!C8;IF(AP_KS=0;"";AP_KS);0=1;)}
The following copies a selected range from one sheet (given a sequence of columns) onto a selected column in another, skipping the headers. It works with a couple activex comboboxes for selecting the columns rather than dropdowns and named range.
The column subset is partly dynamic, based on the existence of headers & some constants; updates whenever switching sheets (adding to workbook open is a good idea, and selection change is an overkill in my opinion).
Private Sub ComboBox1_Change()
Copypasta
End Sub
Private Sub ComboBox2_Change()
Copypasta
End Sub
Private Sub Worksheet_Activate()
' Both sheets.
Update_Combox
End Sub
' I've put the following code in a separate module for accessibility.
Const CFIRSTCOL = 6
Const CLASTCOL = -1
Const CSHEET = "Sheet1"
Const PFIRSTCOL = 1
Const PLASTCOL = -1 ' 3
Const PDEFCOL = 1 ' This is 0 indexed.
Const PSHEET = "Sheet2"
Sub Update_Combox()
' Populates the column selection lists.
Dim indstop As Boolean
Dim i As Integer
Dim ctrlsht
Dim csht
Set csht = Sheets(CSHEET)
Set ctrlsht = Sheets(CSHEET)
ctrlsht.ComboBox1.Clear
indstop = False
i = CFIRSTCOL
While Not indstop
If i > CLASTCOL And CLASTCOL <> -1 Then
indstop = True
ElseIf csht.Cells(1, i) = "" Then
indstop = True
Else
ctrlsht.ComboBox1.AddItem csht.Cells(1, i)
End If
i = i + 1
Wend
Set csht = Sheets(PSHEET)
ctrlsht.ComboBox2.Clear
indstop = False
i = PFIRSTCOL
While Not indstop
If i > PLASTCOL And PLASTCOL <> -1 Then
indstop = True
ElseIf csht.Cells(1, i) = "" Then
indstop = True
Else
ctrlsht.ComboBox2.AddItem csht.Cells(1, i)
End If
i = i + 1
Wend
ctrlsht.ComboBox2.ListIndex = PDEFCOL
End Sub
Sub Copypasta()
' Copypasta selected column to another sheet.
Dim copycol As Integer
Dim pastacol As Integer
Dim lastrow As Integer
Dim lastrow2 As Integer
Dim csht
Dim psht
Set csht = Sheets(CSHEET)
Set psht = Sheets(PSHEET)
If csht.ComboBox1.ListIndex <> -1 And csht.ComboBox1.ListIndex <> -1 Then
copycol = CFIRSTCOL + csht.ComboBox1.ListIndex
pastacol = PFIRSTCOL + csht.ComboBox2.ListIndex
' Need to clear the entire pasta range first.
lastrow2 = psht.Cells(Rows.Count, pastacol).End(xlUp).Row
if lastrow2 > 1 then
Range(psht.Cells(2, pastacol), psht.Cells(lastrow2, pastacol)).Clear
end if
lastrow = csht.Cells(Rows.Count, copycol).End(xlUp).Row
Range(psht.Cells(2, pastacol), psht.Cells(lastrow, pastacol)).Value = _
Range(csht.Cells(2, copycol), csht.Cells(lastrow, copycol)).Value
'psht.Activate
Else
' pass
End If
End Sub
Edit: Added some notes and small bugfix above. Including some shots below for reference.
Code
Dropbox
Other dropbox
Target sheet, empty
Copy
Pasta
This section of code should loop through the table of data in the column I tell it to, and if it is not 0 or blank it should copy the whole row of the table to another spreadsheet which is my formatted reports sheet.
This code seems good to me, and I have other similar pieces of code that work fine but this one does not for some reason.
Public Sub getActiveCodes()
Dim tRows
Dim i As Integer
Dim ws As Worksheet, rpts As Worksheet
Dim nxtRow As Integer
Set ws = Worksheets("Sheet1")
Set rpts = Worksheets("REPORTS")
For i = 1 To i = ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0_
Or "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial , Paste:=xlPasteValues
End If
Next i
End Sub
I would like this function to make a report of all data pertaining to each row item that is not zero in this column.
Cleaned up the code for you
Public Sub getActiveCodes()
Dim tRows
Dim i As Long, nxtRow As Long
Dim wb As Workbook
Dim ws As Worksheet, rpts As Worksheet
Set wb = Workbooks(REF)
Set ws = wb.Worksheets("Sheet1")
Set rpts = wb.Worksheets("REPORTS")
For i = 1 To ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0 _
Or ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial xlPasteValues
End If
Next i
End Sub
Problem was your underscore and the general If statement. Before a line break, add a space. Moreover you shouldn't do If x = 1 Or 2, you should always include the value you compare it to, so If x = 1 Or x = 2. That is because If x = 1 Or 2 reads as if x = 1 is true or if 2 is true, which will always be true because whether or not x = 1, there is nothing false about the number 2 on its own.
Using the Copy function to just copy values is slow. You're better off equalising the values of two ranges like Range("A1:A20").Value = Range("B2:B21").Value