Posts by Mawhrin

Re: Any way to deselect a select in VBA?

Hi there,

There are 2 simple ways to achieve this, first, don't select the sheet to start with

ThisWorkbook.Sheets("Sheet1").UsedRange.Value = ThisWorkbook.Sheets("Sheet1").UsedRange.Value

or, just select another range when done

ThisWorkbook.Sheets("Sheet1").Range("A1").select

Re: Adding current date and time to multiple columns

you're welcome

Re: Adding current date and time to multiple columns

Hi there,

A small change as follows:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D2:D100")) Is Nothing Or Not Intersect(Target, Range("G2:G100")) Is Nothing Then
        Target(1, 2) = Date
        Target(1, 2).EntireColumn.AutoFit
        Target(1, 3) = Time
        Target(1, 3).EntireColumn.AutoFit
    End If
End Sub

Re: Compare two worksheets with row comparison

A sample workbook would be helpful to understand how this will work, or at least give an idea. Are the unique access keys being copied across?

Re: Find Cell Value in Range

Hi excedrin,

The code is fine, it just depends on the behaviour you want & where. If you want the copyright symbol automatically added after entering a value then you will want the sheet events for change as below. It will be required for all sheets you want this to be done for.

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    
    For Each c In Worksheets("Reference Sheet").Range("A10:A14")
        If Target.Value = c Then
            Target.Value = Target.Value & Chr(169)
            Exit Sub
        End If
    Next c
End Sub

Re: Macro to open Word Document through Excel

Hi there,

This will dowhat you want assuming a full path & document name in B1. Make sure to reference the word object library to make it work.

Option Explicit


Sub OpenWordDoc()
    'Requires a reference to the Word library:
    'Tools > References > Microsoft Word x.x Object Library
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then 'Word not yet running
      Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    wdApp.Visible = True
    
    Set wdDoc = wdApp.Documents.Open(Range("B1").Text)
    
End Sub

Re: Find Cell Value in Range

If you want to upload a workbook to look at it would be helpful. But it sounds like this can be done without VBA using a mix of match & char worksheet functions.

Re: Find Cell Value in Range

Hi,

You should not have added ByVal Sh as Object to the declaration line.

If you just want the copyright symbol you canuse the worksheet function =CHAR(169).

Re: VLook up not capturing all info needed

Hi,

Maybe a mix of Match & Index...
http://fiveminutelessons.com/l…dex-match-instead-vlookup

Re: Altering email code to include other attachments (pdf of workbook)

Hi there,

You'll need something along these lines to create the pdf file

Dim arrSheets() As String
    Dim iVisible As Integer
    Dim ws As Worksheet
    
    ReDim arrSheets(0)
    
    For Each ws In dest.Worksheets
        If ws.Visible Then
            ReDim Preserve arrSheets(iVisible)
            arrSheets(iVisible) = ws.Name
            iVisible = iVisible + 1
        End If
    Next ws
        
    dest.Sheets(arrSheets()).Select
    dest.Sheets(arrSheets(0)).Activate
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        TempFilePath & TempFileName & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

And you should be able to add the pdf with

.Attachments.Add TempFilePath & TempFileName & ".pdf"

Re: Kind of editable DataGrid in UserForm

Hmm, initial reading suggested it might fit the bill but further investigation suggests it's no longer supported which is a shame.

That being so if a useform solution is required I would just layout textboxes & comboboxes & place them inside a frame if you need to move them en-masse.

Re: Kind of editable DataGrid in UserForm

If you want a datasheet on a userform the link below has details on doing this.

http://stackoverflow.com/questions/13527540/how-to-display-part-of-excel-on-vba-form

Re: Data Validation? Index? Transpose? Offset? Not sure the best path.

Hi there, it's not clear exactly which responses are driving what tasks as a result so it is difficult to be overly helpful. But looking at the variety of tasks this might be best accomplished using a command button click event, it really depends on how the responses are related to the derived task list.

Re: Getting Username when workbook is opened Readonly

Worked perfectly, thank you.

Is it possible to find out who has a workbook open when the workbook is not shared? i.e. User1 opens the workbook, User2 then tries to open the same workbook & gets the "do you want to be notified" message indicating someone else is using the workbook. I would then like to be able to run a macro to return the username of whoever has the workbook open so I could send an email but cannot find a way of accessing the "notification list".

Re: If folder doesn't exists

No worries zplugger. I must admit, I use the Dir() function mostly for folder checking & have always worked on the basis that e.g. Dir("C:\Test\") implies a folder or a diretory, but with Dir("C:\Test") it implies a file.

Though that might not exatly be the case having read up with microsoft https://msdn.microsoft.com/en-…k008ty4%28v=vs.90%29.aspx

I should maybe be more explicit with Dir for folders.

Re: If folder doesn't exists

Quote from zplugger;738341

Dim strFolder AsString'Folder to check the existence of with a \ at the end
strFolder = "c:\Sales

The problem is also fixed if you include the "\" as per the comment which you have not done in your code. This can be picked up & corrected with

If Not Right(strFolder, 1) = "\" Then strFolder = strFolder & "\"

after you have assigned a value to strFolder

Re: Excel to Excel Data Connection Trouble

Hi Cytop, many thanks for taking the time to respond, it is appreciated.

In answer to your questions, the backend database can really be either an Access DB or an Excel WB with data tables; although I know next to nothing about Access I do think it would be the preferable option seeing as I understand it will handle the unique IDs without me then needing to handle this in VBA for an Excel solution.

As for the connection method, again, I am flexible about this but think it would be best to be able to run queries via SQL & avoid having to open the source database as over time this will be large & potentially slow to load. I will need the ability to update records as well as just read them so it will need to be a read/write connection. I had/have a working solution to just read the required results from a CSV file, however, this does not allow me to update the entries or I am failing to find the correct syntax/method to do so.

If it should help in anyway here is the code used to access the CSV file, this is how it starts with a button click:

Private Sub CommandButton1_Click()
    UserForm1.ListBox1.Clear
    'Find Clients
    If Trim(Me.TextBox2) <> "" Then
        GetClientFolders (True)
        DisplayResults2
        Else
            GetClientFolders (False)
            DisplayResults2
    End If
    'If Application.CountA(Range("C:C")) > 1 Then Unload Me
End Sub

The next part puts together the SQL query:

Sub GetClientFolders(ClientID As Boolean)
    ClientName = UCase(Trim(UserForm1.TextBox1))
    If ClientName = "" And UserForm1.TextBox2 = "" Then Exit Sub
    If ClientName = "" And UserForm1.TextBox2 <> "" Then
        iResults = 1
        ClientID = True
        Else
            iResults = 0
    End If
   
    PathtoTextFile = "C:\Test Folder\"
    CSVFile = "ClientList.csv"
   
SearchByID: ‘Not sure why I have a label marker here, it doesn’t seem necessary
    If iResults = 1 And ClientID = True Then
        FindID = UCase(Trim(UserForm1.TextBox2))
        Query = "SELECT * from " & CSVFile & " WHERE UCase(ClientID) Like '%XXXX%'"
        Query = Replace(Query, "XXXX", FindID)
        ClientID = False
        Else
            Query = "SELECT * from " & CSVFile & " WHERE UCase(ClientFolders) Like '%XXXX%'"
            Query = Replace(Query, "XXXX", ClientName)
    End If
   
    GetConnection (PathtoTextFile)
   
    Recordset.Open Query, Connection, adOpenForwardOnly, adLockOptimistic, adCmdText
 
End Sub

This opens the connection:

Sub GetConnection(PathtoTextFile As String)
   
    Const adOpenStatic = 3
    Const adLockOptimistic = 4 '3
    Const adCmdText = &H1
   
    Set Connection = CreateObject("ADODB.Connection")
    Set Recordset = CreateObject("ADODB.Recordset")
    Set wsFront = ThisWorkbook.Sheets("Front")
 
    Connection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & PathtoTextFile & ";" & _
          "Extended Properties=""text;HDR=YES;FMT=Delimited;ReadOnly=False;"""
 
End Sub

And this is to display the results:

Sub DisplayResults2()
Dim iRow As Integer
    iRow = 0
    Col = 0
 
    With Recordset
        If Not (.EOF And .BOF) Then
            .MoveFirst 
            Do Until .EOF = True
                Col = 0
                UserForm1.ListBox1.AddItem
                UserForm1.ListBox1.List(iRow, Col) = Recordset!ClientFolders   
                Col = Col + 1
                UserForm1.ListBox1.List(iRow, Col) = Recordset!ClientID
                iRow = iRow + 1
               
                .MoveNext
            Loop
        End If
    End With
   
End Sub

Re: If folder doesn't exists

try this

Private Sub CommandButton1_Click()
     
    Const strAltFolder As String = "C:\Users\larry\dropbox\Sales\Misc\"
    Dim MSG As Long
    Dim strFolder As String 'Folder to check the existence of with a \ at the end
    
    strFolder = "c:\Users\larry\dropbox\Sales\" & Range("C13") & "\"
    
    If Not Dir(strFolder) <> "" Then
        MSG = MsgBox("Folder (" & strFolder & ") does not exist.  Do you want to save in " & _
        strAltFolder & ") instead?", vbYesNo, "Notification")
        If MSG = vbYes Then
            ChDir strAltFolder
        Else
            Exit Sub
        End If
    Else
        ChDir "c:\Users\larry\dropbox\Sales\" & Range("C13") & "\"
    End If
     
     
    
     
     
     ''''''Dim varFullName As Variant
    Dim strFileName As String
     
     
    Cancel = True
     
     
    strFileName = ThisWorkbook.Sheets("Sheet1").Range("c16").Value
    varFullName = Application.GetSaveAsFilename(InitialFileName:=strFileName, _
    fileFilter:="Microsoft Excel Workbook (*.xlsm), *.xlsm")
     
    If varFullName <> Cancel And varFullName <> False Then
        On Error GoTo FileNotSaved
        Application.EnableEvents = False
        ThisWorkbook.SaveAs Filename:=varFullName
        Application.EnableEvents = True
    End If
     
     
    Exit Sub
     
     
FileNotSaved:
     
     
    Application.EnableEvents = True
     
End Sub

Re: If folder doesn't exists

Quote from zplugger;738213

Here is the code I use now,works perfect if folder exists. Range C13 is the folder name

Code

Private Sub CommandButton1_Click()




ChDir "c:\Users\tom\retail\Sales\" & Range("C13")




Dim varFullName As Variant
    Dim strFileName As String




    Cancel = True




    strFileName = ThisWorkbook.Sheets("Sheet1").Range("c16").Value
varFullName = Application.GetSaveAsFilename(InitialFileName:=strFileName, _
                                                fileFilter:="Microsoft Excel Workbook (*.xlsm), *.xlsm")
                                                
   If varFullName <> Cancel And varFullName <> False Then
          On Error GoTo FileNotSaved
              Application.EnableEvents = False
                  ThisWorkbook.SaveAs Filename:=varFullName
              Application.EnableEvents = True
    End If




    Exit Sub




FileNotSaved:




    Application.EnableEvents = True
                                                
End Sub

Display More

This doesn't show me where & how you've tried to incorporate the new code.