I'm using Visual Basic to export a General Summary Report To excel using Quickbooks SDK QBFC13Lib.
On the response, I can't get the column titles. I need the column titles as text to send to an excel cell.
The code for the column titles is at 'Get value of NumColTitleRows
I have a text box MsgBox(ColTitle.value) that I was trying to show the column titles so I could see I was getting them.
enter code here
Public Sub WalkReportRet(ReportRet As IReportRet)
If (ReportRet Is Nothing) Then
Exit Sub
End If
'Go through all the elements of IReportRet
'Get value of ReportTitle
Dim ReportTitle10687 As String
ReportTitle10687 = ReportRet.ReportTitle.GetValue()
'Get value of ReportSubtitle
Dim ReportSubtitle10688 As String
ReportSubtitle10688 = ReportRet.ReportSubtitle.GetValue()
'Get value of NumRows
Dim NumRows10690 As Integer
NumRows10690 = ReportRet.NumRows.GetValue()
'Get value of NumColumns
Dim NumColumns10691 As Integer
NumColumns10691 = ReportRet.NumColumns.GetValue()
'SEND TO EXCEL
Dim appXL As Excel.Application
Dim wbXl As Excel.Workbook
Dim shXL As Excel.Worksheet
Dim raXL As Excel.Range
' Start Excel and get Application object.
appXL = CreateObject("Excel.Application")
appXL.Visible = True
' Add a new workbook.
wbXl = appXL.Workbooks.Add
shXL = wbXl.ActiveSheet
'Create an array to set multiple values at once.
Dim qbdata(200, 10) As String
qbdata(0, 0) = ReportTitle10687
qbdata(0, 1) = ReportSubtitle10688
qbdata(0, 2) = NumRows10690.ToString
qbdata(0, 3) = NumColumns10691.ToString
'Get value of NumColTitleRows
Dim NumColTitleRows10692 As Integer
NumColTitleRows10692 = ReportRet.NumColTitleRows.GetValue()
If (Not ReportRet.ColDescList Is Nothing) Then
Dim i10693 As Integer
For i10693 = 0 To ReportRet.ColDescList.Count - 1
Dim ColDesc As IColDesc
ColDesc = ReportRet.ColDescList.GetAt(i10693)
If (Not ColDesc.ColTitleList Is Nothing) Then
Dim i10694 As Integer
For i10694 = 0 To ColDesc.ColTitleList.Count - 1
Dim ColTitle As IColTitle
ColTitle = ColDesc.ColTitleList.GetAt(i10694)
MsgBox(ColTitle.value)
Next i10694
End If
'Get value of ColType
Dim ColType10695 As ENColType
ColType10695 = ColDesc.ColType.GetValue()
Next i10693
End If
If (Not ReportRet.ReportData Is Nothing) Then
If (Not ReportRet.ReportData.ORReportDataList Is Nothing) Then
Dim i10696 As Integer
'this runs the rows
For i10696 = 0 To ReportRet.ReportData.ORReportDataList.Count - 1
Dim ORReportData10697 As IORReportData
ORReportData10697 = ReportRet.ReportData.ORReportDataList.GetAt(i10696)
If (Not ORReportData10697.DataRow Is Nothing) Then
If (Not ORReportData10697.DataRow Is Nothing) Then
If (Not ORReportData10697.DataRow.RowData Is Nothing) Then
End If
If (Not ORReportData10697.DataRow.ColDataList Is Nothing) Then
Dim i10698 As Integer
For i10698 = 0 To ORReportData10697.DataRow.ColDataList.Count - 1
Dim ColData As IColData
ColData = ORReportData10697.DataRow.ColDataList.GetAt(i10698)
qbdata(i10696 + 5, i10698) = ColData.value.GetValue.ToString
Next i10698
End If
End If
End If
If (Not ORReportData10697.TextRow Is Nothing) Then
If (Not ORReportData10697.TextRow Is Nothing) Then
qbdata(i10696 + 5, 0) = ORReportData10697.TextRow.value.GetValue.ToString
End If
End If
If (Not ORReportData10697.SubtotalRow Is Nothing) Then
If (Not ORReportData10697.SubtotalRow Is Nothing) Then
If (Not ORReportData10697.SubtotalRow.RowData Is Nothing) Then
End If
If (Not ORReportData10697.SubtotalRow.ColDataList Is Nothing) Then
Dim i10699 As Integer
For i10699 = 0 To ORReportData10697.SubtotalRow.ColDataList.Count - 1
Dim ColData As IColData
ColData = ORReportData10697.SubtotalRow.ColDataList.GetAt(i10699)
qbdata(i10696 + 5, i10699) = ColData.value.GetValue.ToString
Next i10699
End If
End If
End If
If (Not ORReportData10697.TotalRow Is Nothing) Then
If (Not ORReportData10697.TotalRow Is Nothing) Then
If (Not ORReportData10697.TotalRow.RowData Is Nothing) Then
End If
If (Not ORReportData10697.TotalRow.ColDataList Is Nothing) Then
Dim i10700 As Integer
For i10700 = 0 To ORReportData10697.TotalRow.ColDataList.Count - 1
Dim ColData As IColData
ColData = ORReportData10697.TotalRow.ColDataList.GetAt(i10700)
qbdata(i10696 + 5, i10700) = ColData.value.GetValue.ToString
Next i10700
End If
End If
End If
Next i10696
End If
End If
' Fill A2:B6 with an array of data
shXL.Range("A1", "K205").Value = qbdata
' Make sure Excel is visible and give the user control
' of Excel's lifetime.
appXL.Visible = True
appXL.UserControl = True
' Release object references.
raXL = Nothing
shXL = Nothing
wbXl = Nothing
appXL.Quit()
appXL = Nothing
End Sub
Got it! I had a null on the first item in the list, and wasn't handling it
enter code here
If (Not ReportRet.ColDescList Is Nothing) Then
Dim i10693 As Integer
For i10693 = 0 To ReportRet.ColDescList.Count - 1
Dim ColDesc As IColDesc
ColDesc = ReportRet.ColDescList.GetAt(i10693)
If (Not ColDesc.ColTitleList Is Nothing) Then
Dim i10694 As Integer
For i10694 = 0 To ColDesc.ColTitleList.Count - 1
Dim ColTitle As IColTitle
ColTitle = ColDesc.ColTitleList.GetAt(i10694)
If (Not ColTitle.value Is Nothing) Then
qbdata(i10694 + 2, i10693) = ColTitle.value.GetValue.ToString
End If
Next i10694
End If
Dim ColType10695 As ENColType
ColType10695 = ColDesc.ColType.GetValue()
Next i10693
End If
For reference, this should be universal code for visual studio visual basic to export a balance sheet previous year comparison from open company file into excel. A few small changes would change it to export a P&L. This code only supports up to 200 lines, it would have to be modified for a longer report. (the array expanded and the range in excel expanded).
example of Quickbooks report exported to excel
enter code here Private Sub RunChurchCashFlowReportToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles RunChurchCashFlowReportToolStripMenuItem.Click
DoGeneralSummaryReportBalanceSheetQuery()
DoGeneralSummaryReportProfitAndLossQuery()
' RunCustomSummaryReport()
End Sub
Public Sub DoGeneralSummaryReportBalanceSheetQuery()
Dim sessionBegun As Boolean
sessionBegun = False
Dim connectionOpen As Boolean
connectionOpen = False
Dim sessionManager As QBSessionManager
sessionManager = Nothing
Try
'Create the session Manager object
sessionManager = New QBSessionManager
'Create the message set request object to hold our request
Dim requestMsgSet As IMsgSetRequest
requestMsgSet = sessionManager.CreateMsgSetRequest("US", 13, 0)
requestMsgSet.Attributes.OnError = ENRqOnError.roeContinue
BuildGeneralSummaryReportBalanceSheetQueryRq(requestMsgSet)
'Connect to QuickBooks and begin a session
sessionManager.OpenConnection("", "ChurchReports")
connectionOpen = True
sessionManager.BeginSession("", ENOpenMode.omDontCare)
sessionBegun = True
'Send the request and get the response from QuickBooks
Dim responseMsgSet As IMsgSetResponse
responseMsgSet = sessionManager.DoRequests(requestMsgSet)
'End the session and close the connection to QuickBooks
sessionManager.EndSession()
sessionBegun = False
sessionManager.CloseConnection()
connectionOpen = False
WalkGeneralSummaryReportQueryRs(responseMsgSet)
Catch e As Exception
MessageBox.Show(e.Message, "Error")
If (sessionBegun) Then
sessionManager.EndSession()
End If
If (connectionOpen) Then
sessionManager.CloseConnection()
End If
End Try
End Sub
Public Sub WalkGeneralSummaryReportQueryRs(responseMsgSet As IMsgSetResponse)
If (responseMsgSet Is Nothing) Then
Exit Sub
End If
Dim responseList As IResponseList
responseList = responseMsgSet.ResponseList
If (responseList Is Nothing) Then
Exit Sub
End If
'if we sent only one request, there is only one response, we'll walk the list for this sample
For j = 0 To responseList.Count - 1
Dim response As IResponse
response = responseList.GetAt(j)
'check the status code of the response, 0=ok, >0 is warning
If (response.StatusCode >= 0) Then
'the request-specific response is in the details, make sure we have some
If (Not response.Detail Is Nothing) Then
'make sure the response is the type we're expecting
Dim responseType As ENResponseType
responseType = CType(response.Type.GetValue(), ENResponseType)
If (responseType = ENResponseType.rtGeneralSummaryReportQueryRs) Then
'upcast to more specific type here, this is safe because we checked with response.Type check above
Dim ReportRet As IReportRet
ReportRet = CType(response.Detail, IReportRet)
WalkReportRet(ReportRet)
End If
End If
End If
Next j
End Sub
Public Sub WalkReportRet(ReportRet As IReportRet)
If (ReportRet Is Nothing) Then
Exit Sub
End If
'Go through all the elements of IReportRet
'Get value of ReportTitle
Dim ReportTitle10687 As String
ReportTitle10687 = ReportRet.ReportTitle.GetValue()
'Get value of ReportSubtitle
Dim ReportSubtitle10688 As String
ReportSubtitle10688 = ReportRet.ReportSubtitle.GetValue()
'Get value of NumRows
Dim NumRows10690 As Integer
NumRows10690 = ReportRet.NumRows.GetValue()
'Get value of NumColumns
Dim NumColumns10691 As Integer
NumColumns10691 = ReportRet.NumColumns.GetValue()
'SEND TO EXCEL
Dim appXL As Excel.Application
Dim wbXl As Excel.Workbook
Dim shXL As Excel.Worksheet
Dim raXL As Excel.Range
' Start Excel and get Application object.
appXL = CreateObject("Excel.Application")
appXL.Visible = True
' Add a new workbook.
wbXl = appXL.Workbooks.Add
shXL = wbXl.ActiveSheet
'Create an array to set multiple values at once.
Dim qbdata(200, 10) As String
qbdata(0, 0) = ReportTitle10687
qbdata(0, 1) = ReportSubtitle10688
qbdata(0, 2) = NumRows10690.ToString
qbdata(0, 3) = NumColumns10691.ToString
'Get value of NumColTitleRows
Dim NumColTitleRows10692 As Integer
NumColTitleRows10692 = ReportRet.NumColTitleRows.GetValue()
If (Not ReportRet.ColDescList Is Nothing) Then
Dim i10693 As Integer
For i10693 = 0 To ReportRet.ColDescList.Count - 1
Dim ColDesc As IColDesc
ColDesc = ReportRet.ColDescList.GetAt(i10693)
If (Not ColDesc.ColTitleList Is Nothing) Then
Dim i10694 As Integer
For i10694 = 0 To ColDesc.ColTitleList.Count - 1
Dim ColTitle As IColTitle
ColTitle = ColDesc.ColTitleList.GetAt(i10694)
If (Not ColTitle.value Is Nothing) Then
qbdata(i10694 + 2, i10693) = ColTitle.value.GetValue.ToString
End If
Next i10694
End If
Dim ColType10695 As ENColType
ColType10695 = ColDesc.ColType.GetValue()
Next i10693
End If
If (Not ReportRet.ReportData Is Nothing) Then
If (Not ReportRet.ReportData.ORReportDataList Is Nothing) Then
Dim i10696 As Integer
'this runs the rows
For i10696 = 0 To ReportRet.ReportData.ORReportDataList.Count - 1
Dim ORReportData10697 As IORReportData
ORReportData10697 = ReportRet.ReportData.ORReportDataList.GetAt(i10696)
If (Not ORReportData10697.DataRow Is Nothing) Then
If (Not ORReportData10697.DataRow Is Nothing) Then
If (Not ORReportData10697.DataRow.RowData Is Nothing) Then
End If
If (Not ORReportData10697.DataRow.ColDataList Is Nothing) Then
Dim i10698 As Integer
For i10698 = 0 To ORReportData10697.DataRow.ColDataList.Count - 1
Dim ColData As IColData
ColData = ORReportData10697.DataRow.ColDataList.GetAt(i10698)
qbdata(i10696 + 5, i10698) = ColData.value.GetValue.ToString
Next i10698
End If
End If
End If
If (Not ORReportData10697.TextRow Is Nothing) Then
If (Not ORReportData10697.TextRow Is Nothing) Then
qbdata(i10696 + 5, 0) = ORReportData10697.TextRow.value.GetValue.ToString
End If
End If
If (Not ORReportData10697.SubtotalRow Is Nothing) Then
If (Not ORReportData10697.SubtotalRow Is Nothing) Then
If (Not ORReportData10697.SubtotalRow.RowData Is Nothing) Then
End If
If (Not ORReportData10697.SubtotalRow.ColDataList Is Nothing) Then
Dim i10699 As Integer
For i10699 = 0 To ORReportData10697.SubtotalRow.ColDataList.Count - 1
Dim ColData As IColData
ColData = ORReportData10697.SubtotalRow.ColDataList.GetAt(i10699)
qbdata(i10696 + 5, i10699) = ColData.value.GetValue.ToString
Next i10699
End If
End If
End If
If (Not ORReportData10697.TotalRow Is Nothing) Then
If (Not ORReportData10697.TotalRow Is Nothing) Then
If (Not ORReportData10697.TotalRow.RowData Is Nothing) Then
End If
If (Not ORReportData10697.TotalRow.ColDataList Is Nothing) Then
Dim i10700 As Integer
For i10700 = 0 To ORReportData10697.TotalRow.ColDataList.Count - 1
Dim ColData As IColData
ColData = ORReportData10697.TotalRow.ColDataList.GetAt(i10700)
qbdata(i10696 + 5, i10700) = ColData.value.GetValue.ToString
Next i10700
End If
End If
End If
Next i10696
End If
End If
' Fill A2:B6 with an array of data
shXL.Range("A1", "K205").Value = qbdata
' Make sure Excel is visible and give the user control
' of Excel's lifetime.
appXL.Visible = True
appXL.UserControl = True
' Release object references.
raXL = Nothing
shXL = Nothing
wbXl = Nothing
appXL.Quit()
appXL = Nothing
End Sub
Public Sub BuildGeneralSummaryReportBalanceSheetQueryRq(requestMsgSet As IMsgSetRequest)
Dim GeneralSummaryReportQueryRq As IGeneralSummaryReportQuery
GeneralSummaryReportQueryRq = requestMsgSet.AppendGeneralSummaryReportQueryRq()
'Set field value for GeneralSummaryReportType
GeneralSummaryReportQueryRq.GeneralSummaryReportType.SetValue(ENGeneralSummaryReportType.gsrtBalanceSheetPrevYearComp)
'Set field value for DisplayReport
GeneralSummaryReportQueryRq.DisplayReport.SetValue(True)
'set report period
GeneralSummaryReportQueryRq.ORReportPeriod.ReportDateMacro.SetValue(ENReportDateMacro.rdmLastYear)
'Set field value for ReportDetailLevelFilter
GeneralSummaryReportQueryRq.ReportDetailLevelFilter.SetValue(ENReportDetailLevelFilter.rdlfAll)
'Set field value for ReportPostingStatusFilter
GeneralSummaryReportQueryRq.ReportPostingStatusFilter.SetValue(ENReportPostingStatusFilter.rpsfEither)
'Set field value for SummarizeColumnsBy
GeneralSummaryReportQueryRq.SummarizeColumnsBy.SetValue(ENSummarizeColumnsBy.scbTotalOnly)
'Set field value for IncludeSubcolumns
GeneralSummaryReportQueryRq.IncludeSubcolumns.SetValue(False)
'Set field value for ReportCalendar
GeneralSummaryReportQueryRq.ReportCalendar.SetValue(ENReportCalendar.rcFiscalYear)
'Set field value for ReturnRows
GeneralSummaryReportQueryRq.ReturnRows.SetValue(ENReturnRows.rrAll)
'Set field value for ReturnColumns
GeneralSummaryReportQueryRq.ReturnColumns.SetValue(ENReturnColumns.rcAll)
'Set field value for ReportBasis
GeneralSummaryReportQueryRq.ReportBasis.SetValue(ENReportBasis.rbCash)
End Sub
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 have a sub which adds a column from a table to an array (strArr), loops through the array to determine which rows to delete, and adds the row I want to delete to another array (deleteArr). I then loop in reverse order to delete the row. It seems to work fine for a small number of rows, but completely hangs on rows where I have a few thousand matches in deleteArr, even if I let it run forever. Does anyone have an idea what is going on here?
Public Sub DeleteRows(ByVal surveyString As String)
Dim surveyArr() As String
Dim retireArr() As String
Dim strArr() As Variant
Dim deleteArr() As Variant
Dim totalRows As Long
Dim tRange As String
Dim x As Long
Dim y As Long
Dim ws As Worksheet
'Split up fields to delete received from listBox
If surveyString <> "" Then
surveyArr = Split(surveyString, "|")
End If
totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
tRange = "L2:L" & CStr(totalRows)
strArr = Sheets("Employee").Range(tRange).Value
x = 0
If surveyString <> "" Then
'determine which rows match and need to be deleted
'the value in deleteArr is the row to delete
For i = 1 To UBound(strArr)
For i2 = 0 To UBound(surveyArr)
If strArr(i, 1) = surveyArr(i2) Then
'resize the array and add the row value of what we want to delete
ReDim Preserve deleteArr(0 To x)
deleteArr(x) = i + 1
x = x + 1
End If
Next i2
Next i
'delete the row in reverse order so no rows are skipped
Set ws = Sheets("Employee")
y = UBound(deleteArr)
For i = totalRows To 2 Step -1
If i = deleteArr(y) Then
ws.Rows(i).EntireRow.Delete
If y > 0 Then
y = y - 1
End If
End If
Next i
End If
End Sub
You could try to union a range of all rows you want to delete, then delete in one shot. Code is untested, hopefully this points you in the right direction.
Public Sub DeleteRows(ByVal surveyString As String)
Dim surveyArr() As String
Dim retireArr() As String
Dim strArr() As Variant
Dim deleteArr() As Variant
Dim totalRows As Long
Dim tRange As String
Dim x As Long
Dim y As Long
Dim ws As Worksheet
Dim UnionRange As Range
'Split up fields to delete received from listBox
If surveyString <> "" Then
surveyArr = Split(surveyString, "|")
End If
totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
tRange = "L2:L" & CStr(totalRows)
strArr = Sheets("Employee").Range(tRange).Value
Set ws = Sheets("Employee")
If surveyString <> "" Then
'determine which rows match and need to be deleted
'the value in deleteArr is the row to delete
For i = 1 To UBound(strArr)
For i2 = 0 To UBound(surveyArr)
If strArr(i, 1) = surveyArr(i2) Then
If UnionRange Is Nothing Then
Set UnionRange = ws.Rows(i)
Else
Set UnionRange = Union(UnionRange, ws.Rows(i))
End If
End if
Next
Next
If Not UnionRange Is Nothing Then UnionRange.EntireRow.Delete
End If
End Sub
I am creating my customized function. I wrote the code and tested it as “sub and it worked well. Then i converted it into a function to be able to use it in general. Things that i changed are; adding a function declaration, taking input from excel cell and specifying function output. All others remained same.
My function only has one input which is a selected cell from an excel sheet. And i expect that function returns one output. However, it returns 0.
• function declaration. "Function IbpBomLevel(ByVal Target As Range) As Variant
• input of function as selected cell. "ProductID = Target
• output of function. "IbpBomLevel = fullText
I used option explicit to avoid non-exist functionalities. Also, I am sure about the input, function really takes the selected cell as input. But the problem is that in each loop “ProductID must be changed. Hovewer, when i declared that "IbpBomLevel (output of the function) = ProductID and saw that ProductID is the first parameter that user selected from a cell. It means loop not works. When i test it as “sub, i got the result that i want. I am not sure what the problem is.
Option Explicit
Function IbpBomLevel(ByVal Target As Range) As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim MyRange As Range
Dim SourceID As Variant
Dim SourceID2 As Variant
Dim SourceID3 As Variant
Dim Product As Variant
Dim Item As Variant
Dim Location As Variant
Dim Resource As Variant
Dim I As Variant
Dim T As Variant
Dim Z As Variant
Dim X As Variant
Dim Y As Variant
Dim Index As Variant
Dim Index2 As Variant
Dim Index3 As Variant
Dim BomLevel As Variant
Dim FoundCell As Variant
Dim fullText As Variant
Dim ProductID As Variant
ProductID = Target
Set Wb = Workbooks("Kitap.xlsx")
Windows("Kitap.xlsx").Activate
On Error GoTo T_Error
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Set MyRange = Worksheets("Production Source Header").Range("B:C")
SourceID = CVar(Application.WorksheetFunction.VLookup(ProductID, MyRange, 2, False))
I = 1
T = 0
Z = 1
If IsEmpty(SourceID) = False Then
Do While (IsEmpty(SourceID) = False) And (T = 0)
BomLevel = Z
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Set MyRange = Worksheets("Production Source Header").Range("B:C")
SourceID = CVar(Application.WorksheetFunction.VLookup(ProductID, MyRange, 2, False))
Set FoundCell = ActiveSheet.Range("C:C").Find(What:=SourceID)
If Not FoundCell Is Nothing Then
Index = FoundCell.Row
Location = Cells(Index, 1)
Product = Cells(Index, 2)
Else
End If
X = I
I = I + 1
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Item")
Sheets("Production Source Item").Select
Set MyRange = Worksheets("Production Source Item").Range("B:B")
SourceID2 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Do While (IsEmpty(SourceID2) = False) And (I - X = 1)
Set MyRange = Worksheets("Production Source Item").Range("B:B")
SourceID2 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Set FoundCell = ActiveSheet.Range("B:B").Find(What:=SourceID2)
If Not FoundCell Is Nothing Then
Index2 = FoundCell.Row
Item = Cells(Index2, 1)
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Else
End If
Y = I
I = I + 1
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Resource")
Sheets("Production Source Resource").Select
Set MyRange = Worksheets("Production Source Resource").Range("B:B")
SourceID3 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Do While IsEmpty(SourceID3) = False And (I - Y = 1)
Set MyRange = Range("B:B")
SourceID3 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Set FoundCell = ActiveSheet.Range("B:B").Find(What:=SourceID3)
If Not FoundCell Is Nothing Then
Index3 = FoundCell.Row
Resource = Cells(Index3, 1)
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Else
End If
I = I + 1
Loop
Loop
fullText = fullText & " Location: " & Location & " // Header: " & Product & " // Item: " & Item & " // Resource: " & Resource
Z = Z + 1
ProductID = Item
Set MyRange = Worksheets("Production Source Header").Range("B:C")
SourceID = (Application.WorksheetFunction.VLookup(ProductID, MyRange, 2, False))
T_Error:
If Err.Number = 1004 Then
On Error Resume Next
T = 1
Else
End If
Loop
IbpBomLevel = fullText
Else
MsgBox ("Bom Missing")
End If
End Function
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
I have an Excel file with around 70-80 columns. I need to get the min and max values for each columns. I also need the min and max values on Access. I wrote the code both for Access and Excel and the speed of the macro is very different in both. Both are a little different but very similar.
Here is the Excel code :
Public Sub MinAndMax()
Dim i As Long, j As Long
Dim usedTime As Double
usedTime = Timer
Dim nbCol As Long, nbRow As Long
nbCol = Range("A1").End(xlToRight).Column
nbRow = Range("A1").End(xlDown).Row
Dim min As Double, max As Double
Dim temp As Variant
'First column is for the table key
'First row is for table header
For j = 2 To nbCol
min = Cells(2, j)
max = Cells(2, j)
For i = 3 To nbRow
temp = Cells(i, j)
If IsNumeric(temp) Then
If temp > max Then max = temp
If temp < max Then min = temp
End If
Next i
Next j
MsgBox "Time : " Round(Timer - duree) " seconds."
End Sub
This takes approximatively 5 seconds on Excel.
On Access, it's now a function returning an array, with an option indicating if you want the array with the max or min for each columns. So in order to get both min and max, I have to call it twice.
Private Function GetMinAndMax_Access(Optional ByVal getMin As Boolean = False) As Double()
Dim Path As String
Path = "C:\File.xlsx"
Dim appExcel As Excel.Application
Set appExcel = CreateObject("Excel.Application")
appExcel.ScreenUpdating = False
Dim wb As Workbook
Set wb = appExcel.Workbooks.Open(Path)
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim nbCol As Long, nbRow As Long
nbCol = ws.Range("A1").End(xlToRight).Column
nbRow = ws.Range("A1").End(xlDown).Row
ReDim extremum(2 To nbCol) As Double
Dim temp As Variant
Dim i As Long, j As Long 'Again, data start at row 2, column 2
For j = 2 To nbCol
extremum(j) = ws.Cells(2, j)
For i = 3 To nbRow
temp = ws.Cells(i, j)
If IsNumeric(temp) Then
If getMin Then
If temp < extremum(j) Then extremum(j) = temp
Else
If temp > extremum(j) Then extremum(j) = temp
End If
End If
Next i
Next j
GetMinAndMax_Access = extremum
appExcel.ScreenUpdating = True
wb.Close SaveChanges:=False
appExcel.Quit
End Function
This took precisely 29 minutes to perform on the same dataset. Note that I called the function twice, once for min values and once for max ones.
Any idea why the speeds are so different between Access and Excel, and what can be done about that ? It seems really weird to me !
Seems like a bit of a long winded way to get the minimum and maximum numeric values from the columns. The worksheet functions MIN and MAX are pretty fast at doing it so:
In Excel:
Public Sub MinAndMax()
Dim rLastCell As Range
Dim x As Long
Dim colMinMax As Collection
Set rLastCell = Cells.Find(What:="*", After:=Cells(1, 1), SearchDirection:=xlPrevious)
If Not rLastCell Is Nothing Then
Set colMinMax = New Collection
For x = 1 To rLastCell.Column
colMinMax.Add Array(Application.WorksheetFunction.min(Columns(x)), _
Application.WorksheetFunction.max(Columns(x)))
Next x
End If
End Sub
In Access (with late binding so no need to set references):
Sub ToUse()
Dim MyCol As Collection
Set MyCol = New Collection
Set MyCol = GetMinMax("C:\Documents and Settings\crladmin.ADMINNOT\My Documents\MinMax.xlsm", "Sheet1")
End Sub
Private Function GetMinMax(sPath As String, sSheet As String) As Collection
Dim oXL As Object
Dim oWB As Object
Dim oWS As Object
Dim rLastCell As Object
Dim x As Long
Dim colMinMax As Collection
Set oXL = CreateXL
Set oWB = oXL.Workbooks.Open(sPath, False)
Set oWS = oWB.Worksheets(sSheet)
Set rLastCell = oWS.Cells.Find(What:="*", After:=oWS.Cells(1, 1), SearchDirection:=2) '2 = xlPrevious
If Not rLastCell Is Nothing Then
Set colMinMax = New Collection
For x = 1 To rLastCell.Column
colMinMax.Add Array(oXL.WorksheetFunction.min(oWS.Columns(x)), _
oXL.WorksheetFunction.max(oWS.Columns(x)))
Next x
End If
End Function
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
Both procedures will return collections with 2D arrays containing MIN & MAX values for each column:
Item 1(0) - 4
Item 1(1) - 98
Item 2(0) - 3
Item 2(1) - 15