Posts by rollis13

rollis13 · Sep 24th 2021

Glad having been of some help.

For further information I would point out that I'am using Office 2016-32bit.

Anyway the code of your macro looks okay.

rollis13 · Sep 24th 2021

Your macro works correctly for me, shows Outlook only when there is no attachment.

rollis13 · Sep 17th 2021

Glad having been of some help.

rollis13 · Sep 16th 2021

Presuming that your names are in column A from row 1 and have a single comma and a 2 charcter initial you could use this macro. To keep the initials aligned you will have to format the column with a monospaced font (ex. Courier New).

Code

Option Explicit
Sub Pad_With_Space()
    Dim x, lr, rng As Range, pos, maxLen
    'detect max lenght of names
    lr = Range("A" & Rows.Count).End(xlUp).Row
    For x = 1 To lr
        Set rng = Range("A" & x)
        If Len(rng) > maxLen Then maxLen = Len(rng)
    Next x
    'pad with spaces
    For x = 1 To lr
        Set rng = Range("A" & x)
        pos = InStr(1, rng, ",")
        rng = Left(rng, pos) & Space(maxLen - Len(rng) + 1) & Right(rng, 2)
    Next x
End Sub

Display More

rollis13 · Sep 9th 2021

Glad I was able to help.

rollis13 · Sep 9th 2021

It's tricky to use 'Find' with both month and year due to local formatting of dates so I had to change approach, try with this:

Code

Option Explicit
Private Sub WorkSheet_Change(ByVal Target As Range)
    Dim rFnd   As Long
    If Target.Cells.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        rFnd = Range("A1:A" & Target.Row).Find(What:=Target.Value, LookAt:=xlWhole).Row
        Range("B" & Target.Row) = Range("B" & rFnd)
        Range("C" & Target.Row) = Range("C" & rFnd)
        Range("E" & Target.Row) = Range("E" & rFnd)
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        For rFnd = 2 To Target.Row
            If Month(Range("F" & rFnd)) = Month(Range("F" & Target.Row)) And _
               Year(Range("F" & rFnd)) = Year(Range("F" & Target.Row)) Then
                Range("H" & Target.Row) = Range("H" & rFnd)
                Exit For
            End If
        Next rFnd
    End If
    Application.EnableEvents = True
End Sub

Display More

rollis13 · Sep 9th 2021

If I correctly understood your request, could be:

Code

Option Explicit
Private Sub WorkSheet_Change(ByVal Target As Range)
    Dim rFnd   As Long
    If Target.Cells.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        rFnd = Range("A1:A" & Target.Row).Find(What:=Target.Value, LookAt:=xlWhole).Row
        Range("B" & Target.Row) = Range("B" & rFnd)
        Range("C" & Target.Row) = Range("C" & rFnd)
        Range("E" & Target.Row) = Range("E" & rFnd)
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        rFnd = Range("F1:F" & Target.Row).Find(What:=Month(Target.Value), LookAt:=xlPart).Row
        Range("H" & Target.Row) = Range("H" & rFnd)
    End If
    Application.EnableEvents = True
End Sub

Display More

Note that I also added Event checking to avoid redundant triggering.

rollis13 · Sep 9th 2021

The relevant part of my macro is all in the 'If/Then/End If' so all you have to do is add it to your macro, where depends on how your's is structured, maybe just before your 'End Sub'.

Since I have no idea how your project is structured, I believe that a solution for your second request would be the same, create and add a new 'If/Then/End If' and in it change the references to columns and rows.

rollis13 · Sep 8th 2021

Have a try with this macro to be placed in the sheets module.

Code

Option Explicit
Private Sub WorkSheet_Change(ByVal Target As Range)
    Dim rFnd  As Long
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        rFnd = Range("A1:A" & Target.Row).Find(What:=Target.Value, LookAt:=xlWhole).Row
        Range("B" & Target.Row) = Range("B" & rFnd)
        Range("C" & Target.Row) = Range("C" & rFnd)
        Range("E" & Target.Row) = Range("E" & rFnd)
    End If
End Sub

Display More

rollis13 · Sep 8th 2021

A snippet to detect the first empty cell, could be:

Code

Option Explicit
Sub FirstEmptyCell()
    Dim fec    As Long
    With ActiveSheet
        fec = .Range("A8").End(xlDown).Row + 1
        If .Range("A9") = "" Then fec = 9
    End With
    MsgBox fec      'only for testing
End Sub

rollis13 · Sep 5th 2021

Points and trophies are arranged automatically by the Forum, all you can do is use "Likes" for the best posts.

You asked for a macro to do the dirty work, I usually use this one to be found here: Link

Code

Option Explicit
Sub LoseThatWeight()
    Dim x      As Long
    Dim LastRow As Long
    Dim LastCol As Long
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    On Error Resume Next
    For x = 1 To Sheets.Count
        With Sheets(x)
            .Visible = True
            LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                      LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                      LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            .Range(.Cells(1, LastCol + 1), .Cells(Rows.Count, Columns.Count)).Delete
            .Range(.Cells(LastRow + 1, 1), .Cells(Rows.Count, Columns.Count)).Delete
        End With
    Next x
    On Error GoTo 0
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox "Done, now save the file"
End Sub

Display More

Never test on original files.

rollis13 · Sep 5th 2021

Glad having been of some help.

rollis13 · Sep 5th 2021

Did you save the file after Deleting and before any other activity ?

Sorry, no other idea at the moment.

rollis13 · Sep 5th 2021

You need to Delete (not only Clear) all rows and columns after the last valid cell.

For rows: Select first empty row, hold Shift, tap End then Down Arrow, release Shift, apply Delete

For columns: Select first empty column, hold Shift, tap End then Right Arrow, release Shift, apply Delete

rollis13 · Sep 3rd 2021

That's because with MID you extract a string, so when you compare A1=71 it is a string to a number. Should be atleast string to string (or number to number) so your formula in A3 will work with:

=IF(A2="71","seventyone","ERROR")

or

=IF(VALUE(A2)=71,"seventyone","ERROR")

rollis13 · Aug 11th 2021

Looks like it should be (but I'm unable to test it):

Code

Cells(7, iKVI).Value = "=" & Cells(7, iSum).Address(RowAbsolute:=False, ColumnAbsolute:=False) & "/SUM(" & Range(Cells(7, iSales), Cells(LastRow, iSales)).Address & ")"

You have an extra double-quote after:

Code

ColumnAbsolute:=False)

rollis13 · Jul 9th 2021

Could depend on what cell K6 contains but most of all depends on the fact that you are using forbidden characters in the file name.

Try with:

Code

ActiveWorkbook.SaveAs Filename:=Path & SBD & Format(Now(), "DDDD-MMM-D-YYYY") & ".xlsm"

rollis13 · Jul 2nd 2021

Did you modified the macro with my suggestion like this:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Cells.Count > 1 Then Exit Sub   '<= added
   If Intersect(Target, Range("I:I")) Is Nothing Then Exit Sub
   Application.EnableEvents = False
...

rollis13 · Jul 1st 2021

Hi to all.

Try adding this line of code just before you discriminate range "I:I"; might be enough to solve your criticalissue:

If Target.Cells.Count > 1 Then Exit Sub

rollis13 · Jul 1st 2021

Glad I was able to help.

Posts by rollis13

VBA Display no attachment in Outlook

VBA Display no attachment in Outlook

Text alignment in a cell

Text alignment in a cell

Auto Data Input

Auto Data Input

Auto Data Input

Auto Data Input

Auto Data Input

consider last row if there is any blank cell in between

Excel thinks I have over a million used rows

Excel thinks I have over a million used rows

Excel thinks I have over a million used rows

Excel thinks I have over a million used rows

Extract Year part from Date and convert to text

VBA Formula

It still not working

Inserting rows & columns without ruining my macro code.

Inserting rows & columns without ruining my macro code.

Incrementing Column A Values