Code Bug Fix: Removing Strikethrough text and copying to a new column is missing the first dot

Original Source Link

Hi I am using this code to remove any text in a cell that is striked through and copying it to a new column cell.. Its removing the strike through text but when copying the text to a new cell it misses the first dot after the 1. i.e

1.0900 - 1800     its copying as   10900 - 1800
2.0830 - 1700                      2.0830 - 1700 

For Each cel In rng
For i = 1 To Len(cel.Value)
If cel.Characters(i, 1).Font.Strikethrough = False Then
cel.Offset(0, -1).Value = cel.Offset(0, -1).Value & cel.Characters(i, 1).Text

End If
Next

Any idea why its missing the dot? It only does it on the first line on each cell.

The issue is that you write one character after another and if you write 1. into a cell it gets reduced to 1 automatically.

For Each cel In rng
    Dim OutputText As String
    OutputText = vbNullString 'initialize

    For i = 1 To Len(cel.Value)
        If cel.Characters(i, 1).Font.Strikethrough = False Then
            OutputText = OutputText & cel.Characters(i, 1).Text
        End If
    Next i

    cel.Offset(0, -1).Value = OutputText
Next cel

So put all the characters together in a variable and write all at once in the end is even much faster.

Tagged : / /

Code Bug Fix: VBA- how to duplicate values

Original Source Link

I’m having a bit of a problem with my VBA project. I have a list of unique values in column A (300 values, let’s say) and in column B I need to triple each value (so I would get 900 values, each x3) and in column C I need to assign them: A, B, C, A, B, C, A, B, C, etc. so it would look like:

col A: val1 val2 val3 …

col B: val1 val1 val1 val2 val2 val2 …

col C: A B C A B C …

I’m stuck on this, so I would appreciate some tips as I couldn’t find anything even similar on stack, usually it’s just removing duplicates

Dim rowCount As Integer
Dim lrow As Long
Dim rowNum As Variant, element As Variant

lrow = ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
rowCount = 1
assignArrayValue = Array("A", "B", "C")
For rowNum = 1 To lrow
    For Each element In assignArrayValue
        ThisWorkbook.Worksheets(1).Cells(rowCount, "B").Value = ThisWorkbook.Worksheets(1).Cells(rowNum, "A").Value
        ThisWorkbook.Worksheets(1).Cells(rowCount, "C").Value = element
        rowCount = rowCount + 1
    Next
Next

I placed the values that you want repeated in the column A of the worksheet one below another. I have taken some static values such as the columns, worksheets and array as well, check and see if the above code helps in any way. Goodluck!

Tagged : / /

Code Bug Fix: Calculate combinations of inputs/outputs

Original Source Link

There are 3 worksheets (‘directions’, ‘calculation’, ‘combinations’) in a single Excel file, each looks like the following:

‘directions’ sheet:
'directions' sheet
this is the only sheet the user should have interaction with; the user basically copies information about sheet ‘calculation’

‘calculation’ sheet:
'calculation' sheet
this sheet contains list of inputs (simple integers) and outputs (I’ve added column G which explain which formulas are used to calculate outputs from column F)

The aim is to create a VBA script that inserts values from ‘directions’ column C into ‘calculations’ column D, then extracts resulting outputs from column F of ‘calculations’ and saves everything in a single table in sheet ‘combinations’. The resulting table should basically have all combinations of all inputs and respective outputs, looking like:
this

The problem is this solution is not scalable, meaning that now it works only with exactly 3 inputs and 4 outputs. With a different number of inputs/outputs, the script would require manual adjustment to work properly (adding new variables, adding new layers to FOR loop, etc.). Is there a way to make this script self-adjustable for any number of inputs and outputs?

The script I’ve used here:

Sub AllCombinations()

Application.ScreenUpdating = False

Dim thisWB As Workbook
Dim sheetDirections As Worksheet, sheetCalc As Worksheet, sheetComb As Worksheet
Dim input1 As Integer, input2 As Integer, input3 As Integer
Dim output1 As Integer, output2 As Integer, output3 As Integer, output4 As Integer
Dim inputValues1() As String, inputValues2() As String, inputValues3() As String
Dim inputCoords1 As String, intputCoords2 As String, inputCoords3 As String
Dim outputCoords1 As String, outputCoords2 As String, outputCoords3 As String
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim rowNr As Integer

Set thisWB = ThisWorkbook
Set sheetDirections = thisWB.Worksheets("directions")
Set sheetCalc = thisWB.Worksheets("calculation")
Set sheetComb = thisWB.Worksheets("combinations")

' save coordinates of input/output
inputCoords1 = sheetDirections.Cells(2, 2).Value
inputCoords2 = sheetDirections.Cells(3, 2).Value
inputCoords3 = sheetDirections.Cells(4, 2).Value
outputCoords1 = sheetDirections.Cells(2, 6).Value
outputCoords2 = sheetDirections.Cells(3, 6).Value
outputCoords3 = sheetDirections.Cells(4, 6).Value
outputCoords4 = sheetDirections.Cells(5, 6).Value

' clear whole sheet before use
sheetComb.Cells.Clear

' print names in first row
sheetComb.Cells(1, 1).Value = sheetDirections.Cells(2, 1).Value
sheetComb.Cells(1, 2).Value = sheetDirections.Cells(3, 1).Value
sheetComb.Cells(1, 3).Value = sheetDirections.Cells(4, 1).Value
sheetComb.Cells(1, 4).Value = sheetDirections.Cells(2, 5).Value
sheetComb.Cells(1, 5).Value = sheetDirections.Cells(3, 5).Value
sheetComb.Cells(1, 6).Value = sheetDirections.Cells(4, 5).Value
sheetComb.Cells(1, 7).Value = sheetDirections.Cells(5, 5).Value

' split input variables, separator is ';'
inputValues1 = Split(sheetDirections.Range("C2").Value, ";")
inputValues2 = Split(sheetDirections.Range("C3").Value, ";")
inputValues3 = Split(sheetDirections.Range("C4").Value, ";")

' input/output calculation and printing
rowNr = 2
For i1 = 0 To UBound(inputValues1)
    For i2 = 0 To UBound(inputValues2)
        For i3 = 0 To UBound(inputValues3)
            ' inputs - print
            sheetComb.Cells(rowNr, 1).Value = inputValues1(i1)
            sheetComb.Cells(rowNr, 2).Value = inputValues2(i2)
            sheetComb.Cells(rowNr, 3).Value = inputValues3(i3)
            ' outputs - insert
            sheetCalc.Range(inputCoords1).Value = inputValues1(i1)
            sheetCalc.Range(inputCoords2).Value = inputValues2(i2)
            sheetCalc.Range(inputCoords3).Value = inputValues2(i3)
            ' outputs - print
            sheetComb.Cells(rowNr, 4).Value = sheetCalc.Range(outputCoords1).Value
            sheetComb.Cells(rowNr, 5).Value = sheetCalc.Range(outputCoords2).Value
            sheetComb.Cells(rowNr, 6).Value = sheetCalc.Range(outputCoords3).Value
            sheetComb.Cells(rowNr, 7).Value = sheetCalc.Range(outputCoords4).Value

            rowNr = rowNr + 1
        Next i3
    Next i2
Next i1

Application.ScreenUpdating = True

End Sub

Tagged : /

Code Bug Fix: Outlook crashes intermittently when using VBA code to copy table from excel and populate an email with the table

Original Source Link

Completely perplexed by an intermittent error that occurs with a piece of code I’ve written/repurposed to copy a table from excel, upload it to a database, then copy that same table into an email.

One member of my team says it crashes his Outlook 50% of the time, kills it off completely no error message or hanging.

Wondering if its maybe running too fast and I need to put a wait command in?

The part of the code used to copy to the email is below:

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("Input Sheet").Range("A1:B23").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

            With OutMail
            .To = "[email protected]"
            .CC = ""
            .BCC = ""
            .Subject = "Product Submission: " & Sheets("Input Sheet").Range("B3") & " - " & Sheets("Input Sheet").Range("B4")
            .HTMLBody = RangetoHTML(rng)
            '.Body = Selection.Paste
            .Display   'or use .Send
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

and calls the following function to covert table to HTML

Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a html file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Thanks in advance for any help/observations

G

Tagged : / / /

Code Bug Fix: Check if the file exists using VBA

Original Source Link

Sub test()

thesentence = InputBox("Type the filename with full extension", "Raw Data File")

Range("A1").Value = thesentence

If Dir("thesentence") <> "" Then
    MsgBox "File exists."
Else
    MsgBox "File doesn't exist."
End If

End Sub

In this when i pickup the text value from the input box, it doesn’t work. If however, if remove "the sentence" from If Dir() and replace it with an actual name in the code, it works. Can somebody help?

Note your code contains Dir("thesentence") which should be Dir(thesentence).

Change your code to this

Sub test()

thesentence = InputBox("Type the filename with full extension", "Raw Data File")

Range("A1").Value = thesentence

If Dir(thesentence) <> "" Then
    MsgBox "File exists."
Else
    MsgBox "File doesn't exist."
End If

End Sub

Use the Office FileDialog object to have the user pick a file from the filesystem. Add a reference in your VB project or in the VBA editor to Microsoft Office Library and look in the help. This is much better than having people enter full paths.

Here is an example using msoFileDialogFilePicker to allow the user to choose multiple files. You could also use msoFileDialogOpen.

'Note: this is Excel VBA code
Public Sub LogReader()
    Dim Pos As Long
    Dim Dialog As Office.FileDialog
    Set Dialog = Application.FileDialog(msoFileDialogFilePicker)

    With Dialog
        .AllowMultiSelect = True
        .ButtonName = "C&onvert"
        .Filters.Clear
        .Filters.Add "Log Files", "*.log", 1
        .Title = "Convert Logs to Excel Files"
        .InitialFileName = "C:InitialPath"
        .InitialView = msoFileDialogViewList

        If .Show Then
            For Pos = 1 To .SelectedItems.Count
                LogRead .SelectedItems.Item(Pos) ' process each file
            Next
        End If
    End With
End Sub

There are lots of options, so you’ll need to see the full help files to understand all that is possible. You could start with Office 2007 FileDialog object (of course, you’ll need to find the correct help for the version you’re using).

Correction to fileExists from @UberNubIsTrue :

Function fileExists(s_directory As String, s_fileName As String) As Boolean

  Dim obj_fso As Object, obj_dir As Object, obj_file As Object
  Dim ret As Boolean
   Set obj_fso = CreateObject("Scripting.FileSystemObject")
   Set obj_dir = obj_fso.GetFolder(s_directory)
   ret = False
   For Each obj_file In obj_dir.Files
     If obj_fso.fileExists(s_directory & "" & s_fileName) = True Then
        ret = True
        Exit For
      End If
   Next

   Set obj_fso = Nothing
   Set obj_dir = Nothing
   fileExists = ret

 End Function

EDIT: shortened version

' Check if a file exists
Function fileExists(s_directory As String, s_fileName As String) As Boolean

    Dim obj_fso As Object

    Set obj_fso = CreateObject("Scripting.FileSystemObject")
    fileExists = obj_fso.fileExists(s_directory & "" & s_fileName)

End Function

just get rid of those speech marks

Sub test()

Dim thesentence As String

thesentence = InputBox("Type the filename with full extension", "Raw Data File")

Range("A1").Value = thesentence

If Dir(thesentence) <> "" Then
    MsgBox "File exists."
Else
    MsgBox "File doesn't exist."
End If

End Sub

This is the one I like:

Option Explicit

Enum IsFileOpenStatus
    ExistsAndClosedOrReadOnly = 0
    ExistsAndOpenSoBlocked = 1
    NotExists = 2
End Enum


Function IsFileReadOnlyOpen(FileName As String) As IsFileOpenStatus

With New FileSystemObject
    If Not .FileExists(FileName) Then
        IsFileReadOnlyOpen = 2  '  NotExists = 2
        Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
    End If
End With

Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
On Error GoTo 0

Select Case iErr
    Case 0: IsFileReadOnlyOpen = 0 'ExistsAndClosedOrReadOnly = 0
    Case 70: IsFileReadOnlyOpen = 1 'ExistsAndOpenSoBlocked = 1
    Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select

End Function    'IsFileReadOnlyOpen

Function FileExists(fullFileName As String) As Boolean
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function

Works very well, almost, at my site. If I call it with “” the empty string, Dir returns “connection.odc“!! Would be great if you guys could share your result.

Anyway, I do like this:

Function FileExists(fullFileName As String) As Boolean
  If fullFileName = "" Then
    FileExists = False
  Else
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
  End If
End Function

I’m not certain what’s wrong with your code specifically, but I use this function I found online (URL in the comments) for checking if a file exists:

Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
    'Code from internet: http://vbadud.blogspot.com/2007/04/vba-function-to-check-file-existence.html
    'Returns True if the passed sPathName exist
    'Otherwise returns False
    On Error Resume Next
    If sPathName <> "" Then

        If IsMissing(Directory) Or Directory = False Then

            File_Exists = (Dir$(sPathName) <> "")
        Else

            File_Exists = (Dir$(sPathName, vbDirectory) <> "")
        End If

    End If
End Function

Function FileExists(fullFileName As String) As Boolean
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function

Very old post, but since it helped me after I made some modifications, I thought I’d share. If you’re checking to see if a directory exists, you’ll want to add the vbDirectory argument to the Dir function, otherwise you’ll return 0 each time. (Edit: this was in response to Roy’s answer, but I accidentally made it a regular answer.)

Private Function FileExists(fullFileName As String) As Boolean
    FileExists = Len(Dir(fullFileName, vbDirectory)) > 0
End Function

based on other answers here I’d like to share my one-liners that should work for dirs and files:

  • Len(Dir(path)) > 0 or Or Len(Dir(path, vbDirectory)) > 0  'version 1 - ... <> "" should be more inefficient generally
    
    • (just Len(Dir(path)) did not work for directories (Excel 2010 / Win7))
  • CreateObject("Scripting.FileSystemObject").FileExists(path)  'version 2 - could be faster sometimes, but only works for files (tested on Excel 2010/Win7)
    

as PathExists(path) function:

Public Function PathExists(path As String) As Boolean
    PathExists = Len(Dir(path)) > 0 Or Len(Dir(path, vbDirectory)) > 0
End Function

Tagged : /

Code Bug Fix: How to add a column to a Power Query table loaded onto Excel?

Original Source Link

I have a Power Query with an SQL source that is Loaded into a table in Excel. I have tried to add a column to that table, so that a user can add comments to a specific record of that table, but when the data gets refreshed and new records are added, the comment stays in the same cell, but the corresponding data is moved around.

Is there a way around that?

Tagged : /

Code Bug Fix: Excel Power Pivot DAX function Multiple Sheets

Original Source Link

I have a problem with DAX function in power pivot.
I have loaded 2 tables in 2 different sheets in the power pivot.
I need to write a function in table1 BadgeRecords which makes a comparison with data located in table2 LeaveReq.
I will need to use a nested if I think, which syntax in Dax should be like the following:

=IF(condition1,result1,IF(condition2,result2,result3))

My function added in an extra column in BadgeRecord sheet looks like this but returns an error that’s caused by the LeaveReq[FROM DATE] field located in table 2 and I’m not getting why. I’m not sure I’m missing something.

=if(BadgeRecords_bk[Leave]= FALSE(); 0; IF(BadgeRecords_bk[Date]=LeaveReq[FROM DATE];1))

Any suggestion?

Consider I have BadgeRecords table which records entry and exit date and time of each employee,
the other table LeaveReq it’s a list of Holiday requests from each employee.
In order not to record a late arrival if an employee took a holiday or permit leave that day I should consider also that.
So First IF condition says true or false if Employee Name in the first table is found in the Leave Request table.
If it founds it then it should check the date of the holiday request in the second table if it matches the one in the first table, if the date it’s the same it should not consider he was late that day cause he took a permit.
Also, a person could take more than one permit, LeaveReq table looks like this:

NAME       | LEAVE DATE | FROM TIME | TO TIME
Mark Smith   20/05/2020    9.00       12.00 
John Green   15/05/2020    9.00       12.00 
Mark Smith   25/05/2020    9.00       11.00

BadgeRecord Table looks like this

NAME       |    DATE    | ENTRY TIME | EXIT TIME
Mark Smith   20/05/2020    12.00       18.00
Mark Smith   21/05/2020    9.00        18.00
Mark Smith   22/05/2020    9.00        18.00
Mark Smith   25/05/2020    11.00        18.00

Tagged : / / /

Code Bug Fix: Editing a filtered data-bound ListObject – strange behaviour

Original Source Link

I’m working on an Excel VSTO workbook project. I source data froma SQL database and populate a seris of sheets with data from various tables. In each sheet I add a ListObject data bound to a DataTable, add some column validation, unlock certain column ranges to allow editing and then protect the sheet.

In general this works perfectly well. The problem that i am facing is that if the user applies a column filter and then tries to edit a cell, the cell value displays a value from a different column in the bound DataTable (?!). More confusingly other cells in the same row also change to show values from a different adjacent column. When I debug I can see that the bound DataTable has the correct expected value the user entered, it’s just what excel display in the grid that is wrong.

It’s not the first issue I’ve encounterd with using ListObject programmatically, but this one has me scratching my head.

There isn’t really any code I can provide here as the issue presents itelf when using the native excel user interface.

So following some further experimentation, it looks as though the entire row shifts one column to the right. It just so happens that I have the first column hidden (as a work-aound to another ListObject bug I encountered). Unhiding the first column fixes the problem.

This is not exactly an answer, just yet another work-around to a bug unlikely to ever get fixed.

Seems to me like the use cases used for testing by the VSTO dev team were not as rigorous as they could have been.

Tagged : / / / /

Code Bug Fix: Range Error when using application.worksheetfunction.Vlookup in VBA excel

Original Source Link

i have the following piece of code:

Function MyLookup(var1 As Variant, range1 As Range, var2 As Integer) As Double
MyLookup = Application.WorksheetFunction.VLookup(var1, range1, var2, False)
End Function

I use this function to calculate some of the parameters in the following function

Function Test(IntMethod As String, CFDate As Date, ValDate As Date, _
              CF As Double, RepFreq As Integer, DiscToDate As String, _
              DiscType As String) As Double
Dim InterpPeriod As Double, PrevDateRate As Double, _
    CurrDateRate As Double, PrevCurvMat As Integer, _
    CurrCurvMat As Integer, rate As Double
Dim Yield_Curves As Range, PrevValDate As Date

Set Yield_Curves = DISC_CFS.Range("Yield_Curves")
PrevValDate = Last_Period(ValDate, CFDate, RepFreq)
'-----------------------------------------------------
InterpPeriod = Application.WorksheetFunction.YearFrac(CFDate, ValDate, 1)
PrevCurvMat = YearsDiff(ValDate, CFDate)
CurrCurvMat = YearsDiff(ValDate, CFDate) + 1
PrevDateRate = MyLookup(PrevValDate, Yield_Curves, 2)
CurrDateRate = MyLookup(ValDate, Yield_Curves, 2)

when i get to MyLookup function, the range is not recognised and it exits the function.
Any hints?

thank you in advance!

I have finally managed to resolve the issue. The error was in one of my lookup variables, which was a date. The date should be converted to long type.

the correct code is the following:

Function MyLookup(var1 As Variant, range1 As Range, var2 As Integer) As Double
MyLookup = Application.WorksheetFunction.VLookup(var1, range1, var2, False)
End Function

And for the main code:

Function Test(IntMethod As String, CFDate As Date, ValDate As Date, _
              CF As Double, RepFreq As Integer, DiscToDate As String, _
              DiscType As String) As Double
Dim InterpPeriod As Double, PrevDateRate As Double, _
    CurrDateRate As Double, PrevCurvMat As Integer, _
    CurrCurvMat As Integer, rate As Double
Dim Yield_Curves As Range, PrevValDate As Date

Set Yield_Curves = DISC_CFS.Range("Yield_Curves")
PrevValDate = Last_Period(ValDate, CFDate, RepFreq)
'-----------------------------------------------------
InterpPeriod = Application.WorksheetFunction.YearFrac(CFDate, ValDate, 1)
PrevCurvMat = YearsDiff(ValDate, CFDate)
CurrCurvMat = YearsDiff(ValDate, CFDate) + 1
PrevDateRate = MyLookup(CLng(PrevValDate), Yield_Curves, 2)
CurrDateRate = MyLookup(CLng(ValDate), Yield_Curves, 2)

thank you for the provided answers and assistance

Tagged : / / / /

Code Bug Fix: Retrieve cells with a specific formatting from other sheets into a new sheet in Excel

Original Source Link

I have a several sheets containing different data of interest. I have highlighted the cells with a specific colour, and it will be helpful to have it shown in a “consolidated” sheet that will fetch the highlighted data from anywhere in the other sheet as long as it has the highlighting.

I would like to show the green interesting cells from sheet2, sheet 3, sheet 4, into column A of Sheet1, based on that specific colour. NB. contents is different, the screenshot is just an example.

I would like to show the green interesting cells from sheet2, sheet 3, sheet 4, into column A of Sheet1, based on that specific colour.

I am a bit confused as if I should use conditional formatting, VLOOKUP, IF, or a mix of all, and I am a bit lost with this.

Tagged : / /