I'm having some trouble with a macro for Excel. The snippet that's giving me trouble is responsible for:
1) allowing the user to select multiple column headers, one by one
2) taking the contents of each columns, in the order of header selection, and concatenating
Here's the code:
Dim concat1() As Range
Dim rng As Variant
Dim i As Variant
Dim g As Integer
Dim metalabels() As String
Dim concated As String
Dim s As Variant
lastrow = Cells(rows.Count, "A").End(xlUp).Row
i = 0
msgselect = MsgBox("Would you like to concatonate?", vbOKCancel)
On Error GoTo Errhandler
If msgselect = vbOK Then
Do
ReDim Preserve concat1(i)
Set concat1(i) = Application.InputBox("Select the headers you would like to concatonate", Default:=ActiveCell.Address, Type:=8)
msgselect = MsgBox("Another cell?", vbOKCancel)
i = i + 1
Loop While msgselect = vbOK
i = i - 1
Errhandler:
End If
ReDim metalabels(i)
For g = 0 To i
metalabels(g) = concat1(g).Text
Next
ActiveSheet.Range("a1").End(xlToRight).Offset(0, 1).Select
ActiveCell = "Situation"
For h = 1 To lastrow - 1
For g = 0 To UBound(metalabels)
concated = concated + metalabels(g) + ": " + concat1(g).Offset(h, 0).Text + " / "
Next
ActiveCell.Offset(h, 0).Value = concated
concated = ""
Next
End Sub
The problem is here:
Set concat1(i) = Application.InputBox("Select the headers you would like to concatonate", Default:=ActiveCell.Address, Type:=8)
If the user selects "Cancel," the code crashes since the loop depends on vbOK. So, I thought I'd put in an error handler, but, as it is, I get the "object variable or with block not set" error.
As you might sense, I'm still a nube with VB. Any help is greatly appreciated.
Thanks!
Place this after your End IF
If concat1(i) Is Nothing Then Exit Sub
Did you try adding if concat1(i) = false then exit sub before incrementing i?
Related
I tried to make a macro that takes all the comments in a word document, filters based on the comment text and then inserts them in excel with the associated text in a note.
I tried each step iteratively and I managed to copy the comments and pasting the wanted results in the same word document. Then I managed to manipulate excel by adding columns and notes.
Everything broke when I integrated the excel part with the comment extraction part. The errors were invalid procedure call for the line with rightParPos = InStr(leftParPos, comment, ")") which I hadn't touched in a while, so I tried outputting the parameters... That lead to a completely different error - an indexing error for the categories array when categoryCount was 0, which also was very strange. After that I tried removing a strange character in a string and then I suddenly got some kind of "can't connect to excel" at Set xlWB = xlApp.Workbooks.Open(FileName:=xlPath).
It seems completely random to me. I'm thinking that it might be some kind of limit or bug in the Microsoft Word environment that is causing these problems. Anyone knowing what could be a cause of these strange errors?
I couldn't find anything out of the ordinary with my code, but maybe someone on S.O. sees something that immediately looks strange. Sorry for the very messy code.
Sub Test()
Dim comment, text As String
Dim pageNr As Integer
Dim codePrefix, fileName As String
Dim newLinePos, leftParPos, rightParPos As Integer
Dim commentNr As Integer
Dim codeWorksheetIndex As Integer
Dim xlFile, xlDir, xlPath As String
'Excel'
Dim xlApp As Object
Dim xlWB As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
xlFile = "TEST"
xlDir = "My\Directory\path\" 'censored
xlPath = xlDir & xlFile
Set xlWB = xlApp.Workbooks.Open(FileName:=xlPath)
codePrefix = "a-code" 'censored
fileName = Left(ActiveDocument.Name, Len(ActiveDocument.Name)-5)
'insert a column as second column in each spreadsheet'
For sheet_index = 1 to 3
With xlWB.Worksheets(sheet_index)
.Range("B:B").Insert
.Cells(1, 2).Formula = fileName
End With
Next sheet_index
For commentNr = 1 To ActiveDocument.Comments.Count
Dim category As String
Dim categories(1 to 2) As String
Dim categoryCount As Integer
Dim numLeft, numRight as Integer
'Dim j As Integer
comment = LCase(ActiveDocument.Comments(commentNr).Range)
text = ActiveDocument.Comments(commentNr).Scope
pageNr = ActiveDocument.Comments(commentNr).Scope.Information(wdActiveEndPageNumber)
'find newline'
newLinePos = InStr(comment, vbCr)
If newLinePos = 0 Then
newLinePos = InStr(comment, vbLf)
If newLinePos = 0 Then
newLinePos = InStr(comment, vbCrLf)
if newLinePos = 0 then
newLinePos = InStr(comment, Chr(10))
if newLinePos = 0 then
ActiveDocument.Content.InsertAfter Text:="ERROR: comment " & commentNr & " misses newline!" & vbNewLine
End If
End If
End If
End If
'set to initial index for leftpar instr'
rightParPos = 1
categoryCount = 0
Do
leftParPos = InStr(rightParPos, comment, "(")
rightParPos = InStr(leftParPos, comment, ")")
If leftParPos > 0 and rightParPos > 0 Then
numLeft = rightParPos-1
numRight = numLeft - leftParPos
category = Trim(Right(Left(comment, numLeft), numRight))
categories(categoryCount) = category
categoryCount = categoryCount + 1
End If
Loop While leftParPos > 0 And rightParPos > 0
comment = fileName & " (s. " & pageNr & ")" & vbNewLine & Trim(Right(comment, Len(comment)-newLinePos))
If Instr(LCase(comment), codePrefix) = 1 Then
For categoryIndex = 0 To categoryCount-1
category = categories(categoryIndex)
If category = "category1" Then
codeWorksheetIndex = 1
ElseIf category = "category2" Then
codeWorksheetIndex = 2
ElseIf category = "category3" Then
codeWorksheetIndex = 3
End If
With xlWB.Worksheets(codeWorksheetIndex)
.Cells(commentNr+1, 2).Formula = text
.Cells(commentNr+1, 2).NoteText comment 'this only worked without =
End With
Next categoryIndex
End If
Next commentNr
End Sub
There are two critical problems with the code that were overlooked and then there was one third problem that wasn't due to the code but which also resulted in errors.
As #TimWilliams mentioned, one case where leftParPos = 0 was unhandled.
The indexing of categories was entirely wrong and faulty in the code.
The strangest error was due to having the excel file on an external harddrive that disconnected and therefore making excel not responding.
I have a call procedure to clear contents of tables across multiple worksheets.
This procedure is invoked only from the 2nd sheet of the workbook. When I invoke this, I am getting Error 1004 "Application-defined or Object-defined error".
Below is the parent code base invoking the sub procedure:
Sub ValidateData_BDV1()
On Error Resume Next
Err.Clear
'''''Define Variables'''''''''
Dim mySheet As Worksheet
Dim mySheetName As String
Dim bdvName As Variant
Dim sqlQuery As String
Dim connectStr As String
Dim wsMatch As Worksheet
Dim myWorkbook As Workbook: Set myWorkbook = ThisWorkbook
'''''''''Set Variables''''''''
cancelEvent = False
Set mySheet = ActiveSheet 'Sets mySheet variable as current active sheet
mySheetName = mySheet.Name
driverName = mySheet.Range("B1").Value2 'Get the value of the TDV driver
' MsgBox driver
dataSourceName = mySheet.Range("B3").Value2 'Get the data source name for the published TDV database
' MsgBox dataSourceName
schemaName = mySheet.Range("B5").Value2 'Get the schema name of the published tdv view
bdvName = mySheet.Range("B6").Value2 'Get the name of the published BDV
''''''''''Refresh data across sheets'''''''''''''
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
'''''''''''''''''''''''''''''''''''''''
''''''''''''Call sub procedure'''''''''
Call ClearTableContents
''''''''''''''''''''''''''''''''''''
mySheet.Activate
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
''''''''Show User id and Password box'''''''''
If Len(Uid) < 1 Or Len(Password) < 1 Then
UserForm1.Show
End If
If (cancelEvent = True) Then
Exit Sub
End If
............
............perform some task with error handling
Below is the code base of the called Sub
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim j As Integer
'''''Iterate through the Bdv1, bdv2 and Match sheets. Set default table sizes for each
sheet'''''''''
For j = 2 To 4
If (j = 2) Or (j = 3) Then
rowCount = 5
colCount = 6
ElseIf (j = 4) Then
rowCount = 5
colCount = 9
End If
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
Set wrksht = ActiveWorkbook.Worksheets(j)
Set objListObj = wrksht.ListObjects 'Get list of tables objects from the current sheet
'''''''Iterate through the tables in the active worksheet''''''''''''''
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = wrksht.ListObjects(tableName)
On Error Resume Next
''''''For each table clear the contents and resize the table to default settings''''''''''''
With wrksht.ListObjects(i)
.DataBodyRange.Rows.Clear
.Range.Rows(rowCount & ":" & .Range.Rows.Count).Delete
.HeaderRowRange.Rows.ClearContents
.HeaderRowRange.Rows.Clear
.Range.Columns(colCount & ":" & .Range.Columns.Count).Delete
.Resize .Range.Resize(rowCount, colCount)
End With
wrksht.Columns("A:Z").AutoFit
Next i
Next j
ThisWorkbook.Worksheets(2).Activate '''set the active sheet to the sheet number 2
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
Exit Sub
'Error Handling
NoTableSelected:
MsgBox "There is no Table currently selected!", vbCritical
End Sub
Please help in resolving the issue.
If I execute as independent macro on click of the button, it works perfectly well.
I am going to post this as an "answer", since I think it may at least help, if not solve, your issue.
Clearing tables (list objects) via VBA code can be a little tricky, and I learned this hard way. I developed and have been using the below function for quite some time and it works like a charm. There are comments to explain the code in the function.
Sub clearTable(whichTable As ListObject)
With whichTable.DataBodyRange
'to trap for the bug where using 'xlCellTypeConstants' against a table with only 1 row and column will select all constants on the worksheet - can't explain more than that its a bug i noticed and so did others online
If .rows.count = 1 And .columns.count = 1 Then
If Not .Cells(1, 1).HasFormula Then .Cells(1, 1).ClearContents
Else
'my tables often have formulas that i don't want erased, but you can remove if needed
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
'remove extra rows so table starts clean
Dim rowCount As Long
rowCount = .rows.count
If rowCount > 1 Then .rows("2:" & rowCount).Delete 'because you can't delete the first row of the table. it will always have 1 row
End With
End Sub
Call the procedure like this:
Dim lo as ListObject
For each lo in Worksheets(1).ListObjects
clearTable lo
next
Commented line to make my code work
.Range.Columns(colCount & ":" &
.Range.Columns.Count).Delete
I am very new to VBA, having started programming it yesterday. I am writing a data processing program which requires keeping track of two cells, one on each spreadsheet. The code which reproduces the errors I am experiencing is below. When I call the sub moveCell() in sub Processor(), nothing happens to DIRow and DIColumn, and the code spits out error 1004 at the line indicated. I have tried using DICell = DICell.Offset(), but it returns the same error.
How can I redefine a Range variable to be a different cell?
'<<Main Processor Code>>'
Sub Processor()
Dim PDRow As Integer
Dim PDColumn As Integer
Dim DIRow As Integer
Dim DIColumn As Integer
PDRow = 1
PDColumn = 1
DIRow = 1
DIColumn = 1
Dim PDCell As Range
Dim DICell As Range
Set PDCell = Worksheets("Processed Data").Cells(PDRow, PDColumn)
Set DICell = Worksheets("Data Input").Cells(DIRow, DIColumn)
Call moveCell(2, 0, "Data Input")
End Sub
'<<Function which moves the cell which defines the range>>'
Sub moveCell(r As Integer, c As Integer, sheet As String)
If sheet = "Processed Data" Then
PDRow = PDRow + r
PDColumn = PDColumn + c
Set PDCell = Worksheets("Data Input").Cells(PDRow, PDColumn)
ElseIf sheet = "Data Input" Then
DIRow = DIRow + r '<<<<<<This line does nothing to DIRow's value
DIColumn = DIColumn + c
Set DICell = Worksheets("Data Input").Cells(DIRow, DIColumn) '<<<<<<This line causes error 1004
End If
End Sub
As far as I can tell, you could instead use a quick Function instead. There doesn't seem to be any difference in your If statement results in the moveCell() function, except which worksheet you're using.
We can make this simpler by referring to the Range you're passing to moveCell.
Option Explicit ' forces you to declare all variables
Sub something()
Dim PDCell As Range
Set PDCell = Worksheets("Processed Data").Cells(1, 1)
Dim DICell As Range
Set DICell = Worksheets("Data Input").Cells(1, 1)
PDCell.Select ' can remove
Set PDCell = moveCell(2, 0, PDCell, PDCell.Worksheet.Name)
PDCell.Select ' can remove
Worksheets(DICell.Worksheet.Name).Activate ' can remove
DICell.Select ' can remove
Set DICell = moveCell(5, 0, DICell, DICell.Worksheet.Name)
DICell.Select ' can remove
End Sub
Function moveCell(rowsToMove As Long, colsToMove As Long, cel As Range, ws As String) As Range
Set moveCell = Worksheets(ws).Cells(cel.Row + rowsToMove, cel.Column + colsToMove)
End Function
I've included some rows you don't need (which I've marked with a comment afterwards), but that will show you how the routine works. You can step through with F8 to help see it step-by-step.
Edit: Although, you don't need a separate function at all. Just use OFFSET().
Set PDCell = ...whatever originally
Set PDCell = PDCell.Offset([rows],[cols])
I am creating a spreadsheet for a client to manage his ALM. I developped it under Excel and VBA, request of my client.
One sheet "Data" calculates all the vba functions. If i calculate manually each cell all works fine, but if i run the macro it did not.
Do you have a solution? I can post the entire file if needed, for a better investigation.
At the beginning all the calculation where in excel cell, but i created dedicated function for each table, because the file was too big when saved.
Public Sub Main()
Dim i, nb_tableaux As Integer
Dim j, lignemax, BarWidth As Long
Dim ProgressPercentage As Double
Dim echeancier, nomtableau As String
Dim ws_data As Worksheet
Dim c As Range
Me.ProgressLabel.Caption = "Initialisation terminée. "
Set ws_data = Sheets("Data")
lignemax = ws_data.Range("DATA").Rows.Count
Application.ScreenUpdating = True
Application.EnableEvents = True
nb_tableaux = 17
For i = 1 To nb_tableaux
echeancier = tab_Tableaux(i, 0)
nomtableau = tab_Tableaux(i, 1)
Me.ProgressLabel.Caption = "En cours : " & echeancier
ws_data.Range(nomtableau).Calculate
'With Worksheets("Data")
For j = 1 To lignemax
For Each c In ws_data.Range(nomtableau).Rows(j)
formulaToCopy = c.Formula
c.ClearContents
c.Value = formulaToCopy
DoEvents
Next
Me.ProgressLabel.Caption = "En cours : " & echeancier & ", " & Format(j / lignemax, "0.0%") & " completed"
Me.Repaint
Next j
'End With
Me.Bar.Width = i * 200 / nb_tableaux
Me.Bar.Caption = Format(i / nb_tableaux, "0%") & " completed"
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
End Sub
after taking into account the recommandations you gave me for my previous answers, the code works better, but still not for some of the ranges.
My issue come from a wrong calculation of a argument in the fonction.
In fact, I use ligne=activecell.row - 8, to get the ligne of the range to calculate. But it works if i do it manually, as the actual cell is activated, but not when i call the function many times, as i can not activate each cell, it will be too long for the spreadsheet.
How can i get ligne calculated, with the correct address of the cell where the function is written?
I hope i am clear enough. Sorry for my English.
Public Function Taux_Mois(ByVal mMois As Range, ByVal sScenario As Range)
Dim ligne As Long
ligne = ActiveCell.row - 8
Select Case (Range("DATA[Flag]").Cells(ligne).Value = 0) Or (Range("DATA[frequence fixing]").Cells(ligne).Value = 0)
Case True
Taux_Mois = 0
Exit Function
Case False
Dim index_taux As Integer
Dim ajust As Long
index_taux = CInt(Range("DATA[Indexation ID]").Cells(ligne).Value)
If index_taux = 1 Then
ajust = 0
Else
Dim ajust1, dernierfixingt0, freqfixing As Integer
dernierfixingt0 = Range("DATA[Dernier fixing t0]").Cells(ligne).Value
freqfixing = Range("DATA[frequence fixing]").Cells(ligne).Value
ajust1 = (Int((mMois.Value - dernierfixingt0) / freqfixing) * freqfixing)
ajust = Worksheets("Market Data").Range("Taux_" & sScenario.Value).Offset(12 + dernierfixingt0 + ajust1, 1 + index_taux).Value
End If
Taux_Mois = Range("DATA[facteur taux (TVA, base)]").Cells(ligne).Value * (ajust + Range("DATA[Spread / Taux]").Cells(ligne).Value / 10000)
Exit Function
End Select
End Function
I'm new at VBA coding and working on a match code. The code is working just fine when I run the code in "Data sheet" (the sheet were all my data is and were the match has to be found), but when i'm run the code on the frontpage (Sheet 1 with userforms) the code is debuggen and says "Runtime Error 13". Can anybody tell what the problem is?
And can anybody tell me why my "If isError" doesn't work?
Thanks in advance!
Br
'Find SKU and Test number
Dim icol As Integer
Sheet13.Range("XFD2") = UserForm2.ComboBox1.Value 'Sættes = ComboBox1.value
Sheet13.Range("XFD3") = UserForm2.ComboBox2.Value 'Sættes = ComboBox2.value
icol = [Sheet13.MATCH(XFD2&XFD3,A:A&Q:Q,0)] 'Match af værdien for vores SKU og test nr
With ThisWorkbook.Worksheets("Data sheet")
'If SKU or Test number not found, then messagebox
If IsError("A:A") Then MsgBox "SKU not found": Exit Sub
If IsError("Q:Q") Then MsgBox "Test number not found": Exit Sub
'Add test result/next step and comment
.Cells(icol, 30).Value = Me.ComboBox3.Value
.Cells(icol, 30 + 1).Value = Me.Comments_To_Result.Value
End With
End If
Set objFSO = Nothing
Set openDialog = Nothing
Range("XFD2").Clear
Range("XFD3").Clear
icol should be like this:
icol = Application.match(arg1, arg2, arg3)
See the samples in MSDN:
var = Application.Match(Cells(iRow, 1).Value, Worksheets(iSheet).Columns(1), 0)
Concerning If IsError("A:A") Then MsgBox "SKU not found": Exit Sub, you are doing it wrongly. I assume, that you want to loop through all the cells in the first column and to get whether one of them is an error. You need a loop for this. This is a really simple one, but you should implement it somehow in your code:
Option Explicit
Public Sub TestMe()
Dim rng As Range
For Each rng In Range("A:A")
If IsError(rng) Then Debug.Print rng.Address
Next rng
End Sub