Posts by Luke M

**Luke M** · Jun 28th 2017

Re: Timesheet for double time if over 48 on the 7th day

Hi DrCustUmz,

See if this will work for you. It's not dynamic to hadnle if you start having a different pair of days as your 2 days off, but the calculations seem to work.
I changed the last row to calculate the equivalent paid hours. So, takes your regular hours + 1.5 * overtime hours. The Double row now just simply says "Yes" if we need to double the hours for that day. Once we have all the equivalent hours, we can add them up and multiply by the rate.

**Luke M** · Jun 28th 2017

Re: How do I access workbook and worksheet selected by UserForm in a separate module?

When the user has made their selections in UserForm, or are you using Hide or Unload? Since you need the values later in your code, you'll want to make sure you're doing a Hide.

So, whatever button you have to close your form (after user makes selection) will have something like

Code

Me.Hide

**Luke M** · Jun 23rd 2017

Re: Copy data from multiple workbooks into one workbook sharing the same header

Hi asmod, and welcome to the forum!

Check out the code examples here, from Ron: http://www.rondebruin.nl/win/section3.htm

you should be able to use his free Add-in to merge everything, or use one of the other workbook merge examples.

**Luke M** · Jun 23rd 2017

Re: Returning a Formatted Number from a IF statement.

Hi Keljor, and welcome to the forum!

Your formula is the culprit, in that it is returning a number stored as a text string, not a true number, so none of your cell formatting will take affect. You would want your formula to be this:

=IF(NUMBER<=0, 0, WhatGoesHere)

or perhaps, simply:

=MAX(NUMBER, 0)

if the goal is to fetch the any number greater than 0.

Now you can apply a format to the cell with the formula, and it'll actually do something.

**Luke M** · Jun 20th 2017

Re: VBA script: To copy missing rows from one worksheet and insert in another sheet

Hi mailtodp, and welcome to the forum!

I believe this code will work for you. Just might need to change the sheet names at beginning.

Code

Sub MergeData()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim recRow As Long
    Dim lastRow As Long
    Dim fCell As Range
    Dim i As Long
    
    'Define our worksheets
    Set wsSource = Worksheets("Generic")
    Set wsDest = Worksheets("Master")
    
    Application.ScreenUpdating = False
    
    recRow = 1
    
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        For i = 2 To lastRow
            'See if item is in Master sheet
            Set fCell = wsDest.Range("A:A").Find(what:=.Cells(i, "A").Value, lookat:=xlWhole, MatchCase:=False)
            
            If Not fCell Is Nothing Then
                'Record is already in master sheet
                recRow = fCell.Row
            Else
                'Need to move this to master sheet after last found record
                .Cells(i, "A").EntireRow.Copy
                wsDest.Cells(recRow + 1, "A").EntireRow.Insert
                recRow = recRow + 1
            End If
        Next i
    End With
    
    'Clean up
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Display More

**Luke M** · Jun 14th 2017

Re: VBA - Refer to a Column in Cell

Hi toofxd, and welcome to the forum!
You were close. Need to specify that you wanted the values from those ranges. Could do this in one step, but spacing it out for visibility

Code

Sub ExampleCode()
    Dim firstCol As String
    Dim secCol As String
    
    'What cells are our controls in?
    firstCol = Range("A1").Value
    secCol = Range("A2").Value
    
    'Use that info to build our range string
    Range(firstCol & ":" & secCol).FillRight
End Sub

Display More

**Luke M** · Jun 14th 2017

Re: HLOOKUP of text with multiple criteria

Try something like this:

=INDEX(B2:E5, MATCH(ChosenName, A2:A5, 0), MATCH(ChosenCountry, B1:E1, 0))

**Luke M** · Jun 8th 2017

Re: compare array value in a cell with another cell and replace

I would do a text to columns on the data to split it first.Then you can cut/paste to get it all back into a single column. Then, a formula like

=IFERROR(VLOOKUP(A2,'[Other Book.xlsx]Sheet1!A:B, 2, 0), "")

will fetch the results from one workbook to the other.

**Luke M** · Jun 6th 2017

Re: Cannot figure out how to add all these together

try this:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    'Side note, might want better names for your variables. :)
    Dim A As Range, B As Range, Inte As Range, r As Range, N As Range
    Set B = Range("B2")
    Set N = Range("N4")
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    If Not Intersect(B, Target) Is Nothing Then
        Set Inte = Intersect(B, Target)
        For Each r In Inte
            If r.Offset(-1, -1).Value = "" Then
                r.Offset(-1, -1).Value = Date
            End If
        Next r
    ElseIf Not Intersect(N, Target) Is Nothing Then
        Set Inte = Intersect(N, Target)
        For Each r In Inte
            If r.Offset(-1, 0).Value = "" Then
                r.Offset(-1, 0).Value = Date
            End If
        Next r
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Display More

**Luke M** · Jun 5th 2017

Re: Error 1004: Application.Dialogs(xlDialogOpen).Show Mac Excel 2016 Importing Data

Thanks for link to Ron's site. Using his page, it looks like this should work. I've tried to clearly comment where I've pieces your bit of code in.

Code

Sub Select_File_Or_Files_Mac()
    'Select files in Mac Excel with the format that you want
    'Working in Mac Excel 2011 and 2016
    'Ron de Bruin, 20 March 2016
    Dim MyPath As String
    Dim MyScript As String
    Dim MyFiles As String
    Dim MySplit As Variant
    Dim N As Long
    Dim Fname As String
    Dim myBook As Workbook
    Dim OneFile As Boolean
    Dim FileFormat As String
    
    'Your variables
    Dim DestBook As Workbook, SourceBook As Workbook
    Dim DestCell As Range
    Dim RetVal As Boolean
    ' Set object variables for the active book and active cell.
    Set DestBook = ActiveWorkbook
    Set DestCell = ActiveCell




    'In this example you can only select xlsx files
    'See my webpage how to use other and more formats.
    'Pulled info from website to change to Text files
    'http://www.rondebruin.nl/mac/mac015.htm
    FileFormat = "{""public.plain-text""}"




    ' Set to True if you only want to be able to select one file
    ' And to False to be able to select one or more files
    OneFile = True




    On Error Resume Next
    MyPath = MacScript("return (path to desktop folder) as String")
    'Or use A full path with as separator the :
    'MyPath = "HarddriveName:Users:<UserName>:Desktop:YourFolder:"




    'Building the applescript string, do not change this
    If Val(Application.Version) < 15 Then
        'This is Mac Excel 2011
        If OneFile = True Then
            MyScript = _
                "set theFile to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Please select a file"" default location alias """ & _
                MyPath & """ without multiple selections allowed) as string" & vbNewLine & _
                "return theFile"
        Else
            MyScript = _
                "set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _
                "set theFiles to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Please select a file or files"" default location alias """ & _
                MyPath & """ with multiple selections allowed) as string" & vbNewLine & _
                "set applescript's text item delimiters to """" " & vbNewLine & _
                "return theFiles"
        End If
    Else
        'This is Mac Excel 2016
        If OneFile = True Then
            MyScript = _
                "set theFile to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Please select a file"" default location alias """ & _
                MyPath & """ without multiple selections allowed) as string" & vbNewLine & _
                "return posix path of theFile"
        Else
            MyScript = _
                "set theFiles to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Please select a file or files"" default location alias """ & _
                MyPath & """ with multiple selections allowed)" & vbNewLine & _
                "set thePOSIXFiles to {}" & vbNewLine & _
                "repeat with aFile in theFiles" & vbNewLine & _
                "set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
                "end repeat" & vbNewLine & _
                "set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
                "set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
                "set text item delimiters to TID" & vbNewLine & _
                "return thePOSIXFiles"
        End If
    End If




    MyFiles = MacScript(MyScript)
    On Error GoTo 0




    'If you select one or more files MyFiles is not empty
    'We can do things with the file paths now like I show you below
    If MyFiles <> "" Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With




        MySplit = Split(MyFiles, Chr(10))
        For N = LBound(MySplit) To UBound(MySplit)




            'Get file name only and test if it is open
            Fname = Right(MySplit(N), Len(MySplit(N)) - InStrRev(MySplit(N), _
                Application.PathSeparator, , 1))




            If bIsBookOpen(Fname) = False Then




                Set myBook = Nothing
                On Error Resume Next
                Set myBook = Workbooks.Open(MySplit(N))
                On Error GoTo 0




                If Not myBook Is Nothing Then
                '---------------------
                '---------------------
                '---------------------
'                    MsgBox "You open this file : " & MySplit(N) & vbNewLine & _
'                    "And after you press OK it will be closed" & vbNewLine & _
'                    "without saving, replace this line with your own code."
'                    mybook.Close savechanges:=False
                    
                    'YOUR CODE INSERTED HERE
                     ' Copy the contents of the entire sheet containing the text file.
                    With myBook.Worksheets(1)
                        .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell)).Copy
                    End With
                    
                    DestCell.PasteSpecial Paste:=xlValues
                     
                    myBook.Close
                '---------------------
                '---------------------
                '---------------------
                End If
            Else
                MsgBox "We skip this file : " & MySplit(N) & " because it Is already open"
            End If




            Next N
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub




Function bIsBookOpen(ByRef szBookName As String) As Boolean
    ' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Display More

**Luke M** · Jun 2nd 2017

Re: Error 1004: Application.Dialogs(xlDialogOpen).Show Mac Excel 2016 Importing Data

Will this work? (I don't have a Mac, just changed syntax to what would work on PC)

Code

Sub Import()
Dim DestBook As Workbook, SourceBook As Workbook
Dim DestCell As Range
Dim RetVal As Boolean
 
 
 ' Set object variables for the active book and active cell.
Set DestBook = ActiveWorkbook
Set DestCell = ActiveCell
 
 'Remove all other filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
'Add a custom filter
Call Application.FileDialog(msoFileDialogOpen).Filters.Add( _
"Text Files Only", "*.txt")
 
 ' Show the Open dialog box.
RetVal = Application.FileDialog(msoFileDialogOpen).Show
 
 
 ' If Retval is false (Open dialog canceled), exit the procedure.
If RetVal = False Then Exit Sub
 
 
 ' Set an object variable for the workbook containing the text file.
Set SourceBook = ActiveWorkbook
 
 
 ' Copy the contents of the entire sheet containing the text file.
Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)).Copy
 
 
 ' Activate the destination workbook and paste special the values
 ' from the text file.
DestBook.Activate
DestCell.PasteSpecial Paste:=xlValues
 
 
 ' Close the book containing the text file.
SourceBook.Close False
End Sub

Display More

**Luke M** · Jun 2nd 2017

Re: Find text in column then (in that row) add today's date in another column

You are correct, we need to add an additional check to make sure col M is blank.

Code

Sub testFind()
    Dim rng As Range
    Dim fCell As Range
    Dim firstAdd As String
    Dim myWord As String
     
     'What word are you looking for?
    myWord = "Completed"
     
     
     
    Set rng = Range("Priorities_Table[Progress]")
     
    Application.ScreenUpdating = False
     
    With rng
        Set fCell = .Find(what:=myWord, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
         
         'Make sure we found at least one cell
        If Not fCell Is Nothing Then
            firstAdd = fCell.Address
             
             'Loop over our data
            Do
                 'Change corresponding cell in col M if it's blank
                If Cells(fCell.Row, "M").Value = "" Then
                    Cells(fCell.Row, "M").Value = Date
                    Cells(fCell.Row, "M").NumberFormat = "dd/mm/yyyy"
                End If
                Set fCell = .FindNext(fCell)
            Loop Until fCell.Address = firstAdd
        End If
    End With
     
    Application.ScreenUpdating = True
     
End Sub

Display More

**Luke M** · Jun 1st 2017

Re: Find text in column then (in that row) add today's date in another column

Try giving this a shot.

Code

Sub testFind()
    Dim rng As Range
    Dim fCell As Range
    Dim firstAdd As String
    Dim myWord As String
    
    'What word are you looking for?
    myWord = "Completed"
    
    
     
    Set rng = Range("Priorities_Table[Progress]")
     
    Application.ScreenUpdating = False
    
    With rng
        Set fCell = .Find(what:=myWord, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        
        'Make sure we found at least one cell
        If Not fCell Is Nothing Then
            firstAdd = fCell.Address
            
            'Loop over our data
            Do
                'Change corresponding cell in col M
                Cells(fCell.Row, "M").Value = Date
                Cells(fCell.Row, "M").NumberFormat = "dd/mm/yyyy/"
                Set fCell = .FindNext(fCell)
            Loop Until fCell.Address = firstAdd
        End If
    End With
    
    Application.ScreenUpdating = True
        
End Sub

Display More

**Luke M** · May 24th 2017

Re: Copy Rows From One Worksheet To Another If Condition Meets Criteria

Check out Ron's code on "Copy records with the same value in a column to a sheet or workbook", I think it'll do exactly what you're describing.

http://www.rondebruin.nl/win/s3/win006.htm

**Luke M** · May 23rd 2017

Re: Automatically update one master sheet from multiple sheets

You should be able to use the Data - Remove Duplicates feature? Record a macro of yourself using it to get the basic code you need. Something perhaps like

Code

MasterWs.Range("$A$1:$D$1000").RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes

**Luke M** · May 23rd 2017

Re: Out of memory error

this line looks suspicious:

ActiveCell.EntireRow.Value = dateValue

It's trying to apply a value to an entire row...maybe it's just supposed to be a single cell?

Here's your whole code, simplified down a bit. Removed selections, turned off screen updating. Cleared clipboard at end.

Code

Sub CombineData()
    Dim Sht As Worksheet
    Dim yy As String
    Dim mm As String
    Dim dd As String
    Dim hh As String
    Dim dateStr As String
    Dim dateValue As Double
    Dim strName As String
    Dim searchRange As Range
    Dim findRow As Range
     
     
    Application.ScreenUpdating = False
    
    Worksheets.Add(After:=Worksheets(1)).Name = "24-hr PM2.5"
    Worksheets.Add(After:=Worksheets(1)).Name = "8-hr Carbon Monoxide"
    Worksheets.Add(After:=Worksheets(1)).Name = "8-hr Ozone"
    Worksheets.Add(After:=Worksheets(1)).Name = "1-hr Nitrogen Dioxide"
    Worksheets.Add(After:=Worksheets(1)).Name = "24-hr PM10"
    Worksheets.Add(After:=Worksheets(1)).Name = "24-hr Sulphur Dioxide"
     
     
    For Each Sht In ActiveWorkbook.Worksheets
        With Sht
            strName = .Name
            If strName <> "Masterpage" And strName <> "24-hr PM2.5" And _
                strName <> "24-hr Sulphur Dioxide" And strName <> "24-hr PM10" And _
                strName <> "1-hr Nitrogen Dioxide" And strName <> "8-hr Ozone" And _
                strName <> "8-hr Carbon Monoxide" Then
                
                    
                If Len(strName) = 10 Then
                    yy = Right(strName, 2)
                    mm = Mid(strName, 7, 2)
                    dd = Mid(strName, 5, 2)
                    hh = Left(strName, 2)
                Else
                    yy = Right(strName, 2)
                    mm = Mid(strName, 6, 2)
                    dd = Mid(strName, 5, 1)
                    hh = Left(strName, 2)
                End If
                
                If hh = 24 Then
                    hh = 0
                    dateStr = "20" & yy & "/" & mm & "/" & dd & Space(1) & hh & ":" & "00" & ":" & "00"
                    dateStr = DateAdd("d", 1, dateStr)
                Else
                    dateStr = "20" & yy & "/" & mm & "/" & dd & Space(1) & hh & ":" & "00" & ":" & "00"
                End If
                dateValue = CDate(dateStr)
            
             
                Set searchRange = .Range("A1", .Range("A65536").End(xlUp))
                Set findRow = searchRange.Find(what:="region", LookIn:=xlValues, lookat:=xlWhole)
                
                'Base everything off of the findrow
                findRow.Offset(2).EntireRow.Insert
                findRow.Offset(2).Value = dateValue
                
                'Transfer data
                findRow.Offset(2, 6).Resize(5).Copy
                Worksheets("24-hr PM2.5").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
                
                findRow.Offset(2, 5).Resize(5).Copy
                Worksheets("8-hr Carbon Monoxide").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
                
                findRow.Offset(2, 4).Resize(5).Copy
                Worksheets("8-hr Ozone").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
                
                findRow.Offset(2, 3).Resize(5).Copy
                Worksheets("1-hr Nitrogen Dioxide").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
                
                findRow.Offset(2, 2).Resize(5).Copy
                Worksheets("24-hr PM10").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
                
                findRow.Offset(2, 1).Resize(5).Copy
                Worksheets("24-hr Sulphur Dioxide").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
                
                'Delete old record
                .Range("162:162").Delete
            End If
        End With
    Next Sht
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Display More

**Luke M** · May 18th 2017

Re: Increment cell reference by 18 and fill down formulae X 1000 times via Macro

With the attached file (I updated your formulas), you can use this macro.

Code

Sub CopyRecords()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim recRow As Long
    Dim rowCount As Long
    Dim lastRow As Long
     
    Application.ScreenUpdating = False
     
     'The sheets we are  working with
    Set wsSource = ThisWorkbook.Worksheets("Data Sheet")
    Set wsDest = ThisWorkbook.Worksheets("Structure Sheet")
     
    'Clean out previous
    With wsDest
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow < 20 Then lastRow = 20
        .Range("20:" & lastRow).ClearContents
        .Range("A2:H19").ClearContents
    End With
    
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
         
         'Loop over records
        recRow = 2
        For rowCount = 2 To lastRow
            .Cells(rowCount, "A").Resize(1, 3).Copy wsDest.Cells(recRow, "A").Resize(18)
            .Cells(rowCount, "H").Resize(1, 5).Copy wsDest.Cells(recRow, "D").Resize(18)
            
            recRow = recRow + 18
        Next rowCount
    End With
    
    With wsDest
        'Copy down formulas
        .Range("I2:L19").Copy
        .Range("I2:L" & recRow - 1).PasteSpecial xlPasteFormulas
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

Display More

**Luke M** · May 17th 2017

Re: Increment cell reference by 18 and fill down formulae X 1000 times via Macro

Here's a start. Your file didn't include any formulas, or indicate what they should be, so I just left that spot open in the code.

Code

Sub CopyRecords()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim recRow As Long
    Dim rowCount As Long
    Dim lastRow As Long
    
    Application.ScreenUpdating = False
    
    'What sheets are we working with?
    Set wsSource = ThisWorkbook.Worksheets("Sheet1raw data")
    Set wsDest = ThisWorkbook.Worksheets.Add
    
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        'Copy headers
        .Range("A3:S3").Copy wsDest.Range("A1")
        wsDest.Range("T1").Value = "Captions"
        wsDest.Range("U1").Value = "Some other header"
        
        'Loop over records
        recRow = 2
        For rowCount = 4 To lastRow
            'Place output in 18 rows each
            .Cells(rowCount, "A").Resize(1, 19).Copy wsDest.Cells(recRow, "A").Resize(18)
            
            'NOT SURE WHAT GOES IN LAST TWO COLUMNS
            'You didn't say what formula/data was in your example
            
            recRow = recRow + 18
        Next rowCount
        
        
    End With
        
    With wsDest
        'Delete unused columns
        .Range("R1").EntireColumn.Delete
        .Range("H1").EntireColumn.Delete
        .Range("F1").EntireColumn.Delete
        .Range("C1").EntireColumn.Delete
    End With
    
    Application.ScreenUpdating = True
            
End Sub

Display More

Or, if you've already got a somewhat working code, you might be able to use the offset tool. Something like

Code

Dim myCount as Long


myCount = 0
Do until myCount = 100 'Some loop condition
Range("A1").Offset(myCount * 18).Value = Range("B1").Offset(myCount * 18).Value
myCount = myCount + 1
While

**Luke M** · May 12th 2017

Re: VBA Help needed to tweak my Search and Find macro...

Since you already have an Exit Sub after the Search, I think you can just do this

Code

Sub FindInLists()
     '
     ' Select FindInLists Macro
     '
     
    Dim SheetsToSearch
    Dim x As String
    Dim ws As Worksheet
    Dim r As Range
    Dim strKeyword As String
     
    SheetsToSearch = Array("List1", "List2", "List3") '// Enter the exact sheet names of sheets to be searched
     
    x = InputBox("What do you want to search for?", "Search")
     
    If x = "" Then
         'User cancelled
        Exit Sub
    End If
     
    For Each ws In ThisWorkbook.Sheets
        If Not IsError(Application.Match(ws.Name, SheetsToSearch, 0)) Then
            With ws.Range("A1:AB5000")
                Set r = .Find(what:=x, After:=.Range("A1")) 'find the cell whose value is equal to x and activate it
                If Not r Is Nothing Then
                     Application.Goto r
                    Exit Sub
                End If
            End With
        End If
    Next
     
    'If you get to here, you never found anything
    MsgBox "Item not found"
End Sub

Display More

**Luke M** · May 10th 2017

Re: Nested AND and OR statements with different THEN outputs

Simpler solution, if you're interested.

=G5+5*(D5<A10)+5*(E5<12)