Quantcast
Channel: Excel Help Forum - Excel Programming / VBA / Macros
Viewing all 49962 articles
Browse latest View live
↧

Dynamically change sheet name

August 17, 2017, 8:21 am
$
0
0
Hi Guys!

The code I have written below is supposed to activate/select a worksheet that is standing in the range AC28 (as it should be dynamic). In this case AC28 refers to the sheet name 7.
When I try to change the sheetname of sheet '7' to the value of N1 it does not work.

Code:
Sub Macro2()
'
' Macro2 Macro
'

'
    Sheets(Range("AC28").Value).Select
    ActiveSheet.Name = ActiveSheet.Range("N1")

End Sub
Can anyone help me out how to change the sheetname from to the value of N1?

(At the moment even the selecting/activating of the sheet does not work, and it has to be dynamic)

Thank you guys so much!
↧
Search

Macro to Filter Data based on a Specific Cell Value

August 17, 2017, 8:23 am
$
0
0
Hello,

Below is my existing Macro as it was recorded. What I am trying to accomplish is creating one macro to apply to multiple departments, vs. individualized macros. The portion of the macro that should be bolded red is where I believe I need my edit. On a related sheet named "Test Version" in cell B3 I have the name of the department. I want to filter the Accomplishments tab based upon the department in this cell. In this case it was ATM Ops I filtered.

Can someone advise how I can edit this to capture the data filtered by B3 on Test Version vs. having it by the specific department name selection like I do now. FYI I need to keep the All Teams piece of the macro. Please and thank you!

Code:
Sub Accomplishment()
'
' Accomplishment Macro
'

'
    Sheets("CompletedAccomplishments").Select
    ActiveSheet.Range("$A$4:$L$122").AutoFilter Field:=7, Criteria1:= _
        xlFilterThisQuarter, Operator:=xlFilterDynamic
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveSheet.Range("$A$4:$L$122").AutoFilter Field:=2, Criteria1:= _
        "=All Teams", Operator:=xlOr, Criteria2:="=ATM Ops"
    ActiveWindow.SmallScroll Down:=-3
    Range("C:C,G:G,I:I").Select
    Range("I1").Activate
    Selection.Copy
    Sheets("Test Version").Select
    Range("A11").Select
    ActiveSheet.Paste
    Sheets("CompletedAccomplishments").Select
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    Columns("L:L").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Test Version").Select
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    Range("L11").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Rows("11:14").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub
↧
↧

vba to extract partial text from specific columns and merge the in a specified column

August 17, 2017, 8:26 am
$
0
0
I have worksheet named calculations , need to split drinks code from columns D,W Y ,and insert data in column J.

Column M,N,O, does the split by formula based on J.

column Z represent the multiplication column W and Y .

the litrage need to be extracted from column G

to extract data from column W,Y and G to insert it in the format of column J.

The tricky parts are those who are highlighted in yellow, need to extract data in Z and G for J as these are packs of 6 and 12 as specified in column G where the percentage of alcohol need to be extract E.G 15D represents 15% translated in column R as 0.15.

All wines products are taken by default 75 cl then translated to column P as 0.75(tricky description image) but some will be recognised by column H which has a special code 22042190,however take note some have litres description note most of them is derived from french conversion CL that need to be converted in litres from column O to P
However to ease the situation there is a list of code sheet tab drinks to know which item are drinking liquids .
The list is exhaustive as it has to be done manually

Columns M,N ,O ,S,T,U,V have formula which are derived from column J where a vba code is needed as it very painful with more of 3000 lines per day .

Can any one assist
Attached Images
Attached Files
↧

VBA DateValue formula now gives VB error for an empty string

August 17, 2017, 8:33 am
$
0
0
Hi everyone. Has anyone else noticed a change recently, in how DateValue behaves in VBA? I am fairly sure that a few months ago, I tested something like this below in a tool I was developing, and it always worked OK when the string variable stCellVal was empty:

ActiveCell.Value = DateValue(stCellVal)

Even running a query in the immediate window as below, now gives error 13, the same as the above does:

?DateValue("")

The same thing happens in both Excel 2010 and 2013.

Has this changed in Excel in the last few weeks or so - and it didn't used to result in a VB error at all - or is my memory dodgy, and it was always like this?



Many thanks,
Nelson
↧

Correction in code to refresh data when doing amendments

August 17, 2017, 8:43 am
$
0
0
HI

I have below code but when i delete information in sheet "NEW_SITES_RENOVATIONS" it doesn't update correctly in NEW_SITES_RENOVATIONS_TABLE (basically it doesn't delete accordingly)

also in column "date" it addes more data than it should , all columns in "NEW_SiTE_RENOVATIONS_TABLE" must have the same number of rows


thanks in advance

Code:
Sub NEW_SITES_RENOVATIONS_TABLE()
Dim Ray As Variant, n As Long, Ac As Long, c As Long
Ray = Sheets("NEW_SITES_RENOVATIONS").Range("A1").CurrentRegion.Resize(, 16)
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2) + 1, 1 To 5)
c = 1
 nray(c, 1) = Ray(1, 1)
 nray(c, 2) = Ray(1, 2)
 'nray(c, 3) = Ray(1, 3)
 nray(c, 3) = Ray(1, 3)
 nray(c, 4) = "Date"
 nray(c, 5) = "Amount"
For n = 2 To UBound(Ray, 1)
    For Ac = 5 To UBound(Ray, 2)
        c = c + 1
        nray(c, 1) = Ray(n, 1)
        nray(c, 2) = Ray(n, 2)
        'nray(c, 3) = Format(Ray(n, 3), "mmm_yy")
        nray(c, 3) = Ray(n, 3)
        If IsDate(Ray(1, Ac)) Then
                nray(c, 4) = CDate(Ray(1, Ac))
        Else
                nray(c, 4) = Ray(1, Ac)
        End If
        nray(c, 5) = Format(Ray(n, Ac), "#,##0.00000")
    Next Ac
Next n
Sheets("NEW_SITES_RENOVATIONS_TABLE").Range("A1").Resize(c, 5) = nray
End Sub
↧
↧

Using find feature in macro

August 17, 2017, 9:07 am
$
0
0
Hello,

I think this is pretty basic, but I don't have a lot of knowledge on the subject.

I'm trying to record a macro that performs the following steps:

copy the contents of a cell
go to another tab
open find dialogue box
paste contents of copied cell in the find dialogue box
find next and close dialogue box
copy the contents of the cell to left of search results
go back to original tab
paste contents in cell below

This all works fine except when I run the macro, it always finds the exact contents I pasted in the find box when I recorded the macro. So I guess it's not pasting the new contents in the find box when running the macro. Can I make it do that somehow?

This is my first time posting so I hope I'm following the correct procedure and that this is clear.

Thank you for your help!

Deb
↧

Use column heading instead of row letter (i.e. M2:M500)

August 17, 2017, 9:19 am
$
0
0
I have created the below bit of code to calc the average of column M however I have just found out that the template for the data being provided regularly changes (I've asked them to stop but they wont) so I would like to find the column with the heading "AP" rather than look for column "M". I have highlighted the affected section in red. I know it is possible as I have seen it done before but it was 10 yrs ago when I saw my very first macro and I cannot recollect how it was done and I have been unable to google the answer to date.

Can anyone advise how this is done?
Any assistance as always is very welcome and appreciated

Code:
With ThisWorkbook.Sheets(3)
' Determines if AvePay has been set by the system or finds last row and averages row based on cells with a value greater than 0
    RRows = .Range("G" & .Rows.Count).End(xlUp).row
        If AvePay <> 0 Then APAve = AvePay Else APAve = Application.WorksheetFunction.AverageIf(Range("M2:M" & RRows), ">0")
        MAPAve = APAve * -1
↧

Run Macro in selected row

August 17, 2017, 9:29 am
$
0
0
Hi I have a problem I have searched on but could not find.

I have a spreadsheet where I want to format certain rows (which contain about 15 columns per row) only.

For instance, I have 100 rows that are pre-formatted and I want to choose cell A-20, run the macro and make that entire row dark blue and large font, and I want certain cells to have the same text color as the blue background to hide the text in certain cells in the row.

Then I want to do the same thing to row 30 my selecting A-30 and running the macro.
I created the Macro by formatting a row on the sheet but obviousy no matter what cell or row I run it from It formats the row in the original Macro.

I just need it to select the row that is active when I start the Macro.

Using either the first cell in a row or the row selector would be fine.

Here is my macro as-is

Code:
Sub NewJobLine()
'
' NewJobLine Macro
' Add Job line Break
'
' Keyboard Shortcut: Ctrl+j
'
    Range("A12:Q12").Select
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("H12:L12").Select
    With Selection.Font
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = -0.249977111117893
    End With
End Sub

Thanks for any help
↧
Search

Working with dates

August 17, 2017, 9:39 am
$
0
0
The sample shows a table of client names and dates of service (DOS)
I don't even know if I'm looking for a macro, pivot table or advanced filter.

My goal is to get information for both the first DOS and/or the last DOS for each client.
For instance what clients or how many clients had a first DOS in 2016, or any date range?
What clients have not been seen for X days or months or since date?

I'm thinking pivot table but I haven't had much success.

Thanks all!
Attached Files
↧
↧

Loop Macro needs to return blanks in cell for segments that are not found between loops

August 17, 2017, 10:10 am
$
0
0
The following mocked up macro is working for the first piece of searchable criteria (returning a blank cell for the loops in which the string is not found), but when duplicated exactly for the remaining 25 pieces of criteria it needs to search for, it will not return a blank cell. Instead, it will grab the data found in the next loop and duplicate it for both. I cannot figure out why it would work for the first one, and not for the rest when it is written exactly the same way...any help would be so greatly appreciated:

Sub Loops()

S = 1
P = 1

LR = Cells(Rows.Count, 1).End(xlUp).Row

R = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)

Loop1:

S = Range(Cells(S, 1), Cells(LR, 1)).Find("SR~*530~*", LookIn:=xlValues, Lookat:=xlPart).Row
R(0) = Cells(S, 1).Value

E = S

Loop2:
E = Range(Cells(E, 1), Cells(LR, 1)).Find("TE~*", LookIn:=xlValues, Lookat:=xlPart).Row
If UCase(Left(Cells(E, 1), 2)) <> "TE" Then GoTo Loop2


On Error Resume Next
Set pos = Range(Cells(S, 1), Cells(E, 1)).Find("GRO~*", LookIn:=xlValues, Lookat:=xlPart)

If IsError(InStr(pos, "GRO~*")) Then

R(1) = ""

Else
Q = Split(pos, "*")

'***********************
R(1) = Q(8)
'***********************

End If

On Error Resume Next
NextOne = Range(Cells(S, 1), Cells(LR, 1)).Find("…

**Repeats for all 26 ranges**

…End If

Range(Cells(P, 4), Cells(P, 31)).Value = R

P = P + 1
S = Range(Cells(S, 1), Cells(LR, 1)).Find("TE~*", LookIn:=xlValues, Lookat:=xlPart).Row
If S < LR Then GoTo Loop1

End Sub
↧

If function true then remove leading 8 characters false enter as is.

August 17, 2017, 10:57 am
$
0
0
Hi guys
I am attempting to ask an If function to look in one cell and if true then remove the first 8 characters from another cell and enter it, if false then enter as it is.
I have tried lots of way to achieve this. I have no doubt that it is easily done.

I attach an excel sheet as well as the code I have run to achieve the current state of the sheet.
The reason I need to remove these is because I cannot use Vlookup as it does not match my table.
I want to add this to the bottom of the code below.
Code:
Sub CombinedToClean()
'Replace chosen strings with "".
    Cells.Replace What:="Transaction", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
    Cells.Replace What:="Money out", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Money in", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="balance", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 'shift chosen strings from D to populate C
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "ATM Cash Withdrawal"
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "Card Purchase"
    Range("C9").Select
    ActiveCell.FormulaR1C1 = "Inward Payment"
    Range("C10").Select
    ActiveCell.FormulaR1C1 = "Card Purchase"
    Range("C11").Select
    Range("$C$11").FlashFill
    Cells.Replace What:="date", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'Same chosen strings from Column D
    Columns("D:D").Select
    Selection.Replace What:="Direct Debit", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="brought forward", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Inward Payment", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("D:D").Select
    Selection.Replace What:="Card Purchase", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="ATM Cash Withdrawal", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Standing Order", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
       
'Now clean then up what's left
Dim ws As Worksheet
Dim NextRow As Range
 For Each ws In ActiveWorkbook.Sheets
              With ws
' CleanAndTrim Macro
            .Cells.WrapText = False
            .Rows.RowHeight = 12.75
            .Cells.UnMerge
            .Cells.ClearFormats
           
        End With
        Next

       
Dim rng As Range
Dim Area As Range
        'Trim and Clean cell values
        If Selection.Cells.Count = 1 Then
            Set rng = Selection
        Else
            Set rng = Selection.SpecialCells(xlCellTypeConstants)
        End If
        For Each Area In rng.Areas
            Area.Value = Evaluate("IF(ROW(" & Area.Address & "),CLEAN(TRIM(" & Area.Address & ")))")
        Next Area
        Columns("B:B").Select
            Selection.NumberFormat = "dd/mm/yy;@"
       
End Sub
Attached Files
↧

VBA- SQL CopyFromRecordSet got slow without a reason

August 17, 2017, 11:15 am
$
0
0
I have a procedure in VBA that i've been using for some time now to pull the data set from SQL DB.
It always took less then 1 min to populate the template but since few days it's been taking more than 10 mins. nothing changed in Database, nothing changed in my vba code either...
It stucks on :

Sheets("NEW").Range("A3").CopyFromRecordset rst

I even upgraded from office 2013 to 2016 but the issue still persists
Any guesses what could be the reason?


note:
-the same file with same procedure works fine on my colleagues pc
-table in question is about 54000 rows in 34 columns
my code

Code:
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim Combine As String
Dim ow As Long
Dim ok As Integer
Dim i As Long

 ConnectionString = "Provider=SQLOLEDB.1;Password=xxx;Persist Security Info=True;User ID=xxxx;Data Source=xxxx;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Use Encryption for Data=False;Tag with column collation when possible=False;Initial Catalog=Share_Assignment_Automation"


    cnn.Open ConnectionString
    cnn.CommandTimeout = 900

    StrQuery = "SELECT [Organization],null as [ERP Segment 1],[Effective date of assignment to Team],[Expiration date of assignment to Team],null as [Last Modified By],null as [Last Modified Date],[Territory Type Name],[Forecastable Flag],[Inside Sales Flag] FROM [vw_SHARETeam] with (nolock) "

    rst.Open StrQuery, cnn
    Sheets("TEAM").Range("A3").CopyFromRecordset rst

    rst.Close
↧

Code that emails the last saved version of the Activeworkbook is broken

August 17, 2017, 11:50 am
$
0
0
I have the following code that is supposed to email the last saved version of the Activeworkbook. The code instead is emailing a blank workbook. Can someone help me fix this issue? I have attached a sample of my workbook for reference.

Code:

Private Sub MailDailyPnLFile()
'Working in 2000-2010
'This example send the last saved version of the Activeworkbook
    Dim OutApp As Object
    Dim OutMail As Object

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

    On Error Resume Next
    With OutMail
        .To = "randallhudgins@gmail.com"
        .CC = ""
        .BCC = ""
        .Subject = "PnL" & " " & Format$(Date, "m/dd/yy")
        .Body = ""
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send  'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
   
'copy stamp
Workbooks("Live Trade Monitor - IB.xlsm").Activate
Worksheets("Live Trades").Select

Range("AT1").Select
Selection.Copy
Range("AD2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
   
End Sub
Attached Files
↧
↧

Sort rows when column range changes

August 17, 2017, 11:51 am
$
0
0
Hello,

I have a worksheet (Sheet19) where by default I have 5 populated columns A:E, however, I have three teams who may add their own columns to the right of the data set (F:ZZZ). With my current code I sort on column A in Ascending order, however, my code only impacts A:E which becomes out of sync with F:Z. It is important to note - I need to encompass last used column and last used row within the code, and not simply use "A:ZZZ". Here is the example of my code;

Code:
Sub Macro5()
    LastCol = Replace(Sheet19.Cells(1, Sheet19.Columns.Count).End(xlToLeft).Address(False, False), "1", "")
    Sheet19.Range("A1", Range("A" & Rows.Count & ":" & LastCol & Rows.Count).End(xlUp)).Sort [A2], 1, Header:=xlYes
End Sub
↧

[SOLVED] Run-time error '1004' when protecting spreadsheet

August 18, 2017, 7:50 am
$
0
0
I am almost finished with this project and I have 60+ people using it when it's completed. I am trying to protect all of the spreadsheets and I have a VBA code that triggers this error when I try protecting it. I can't figure out why this is happening, so I am asking for some help with the attached workbook. The yellow cells are the unlocked cells and only the first two spreadsheets are protected as of now until I get this figured out. If theres also a way to protect them all at once, I'm open to hearing about that as well.

Passwords are 123456 to unprotect

Thanks in advance!
Attached Files
↧
Search

Export shape settings?

August 18, 2017, 7:55 am
$
0
0
Is it possible to export the formatting of a specific shape?

The reason is that I have created a template textbox with a lot of effects and color settings and it's very time consuming to have to Google each and every one of them to find out how to set them through vba.
↧

How to create a ActiveX dropdown list

August 18, 2017, 7:56 am
$
0
0
hey. being working on this solution for some hours now?
would anyone how how to use VBA code to get this list working..

please see attached sheet

PS it needs to be activex element.

thx for your help.
Attached Files
↧
↧

Max Drawdown + implementation

August 18, 2017, 8:36 am
$
0
0
Hi,

First things first, I have never used a macro/VBA before, so i do not know what im doing.
I've searched for an answer to my problem (below), but don't know how to go about adding it to my worksheet, setting the correct range, putting it into a cell etc..- so i need help with the solution AND getting it into my sheet...

it's just a simple maximum drawdown problem which i could do 'manually', but because the sheet im producing is meant to be saving time, it'd like to have a single cell that will calculate maximum drawdown for its own row - as part of a table.

i've attached a sample sheet, but on my actuall worksheet the dates go back to Oct-86 and not every series goes back the same length of time

any help is appreciated :)
Attached Files
↧

How do I create Label Boxes Programatically

August 18, 2017, 8:39 am
$
0
0
I am creating a program to solve very large Sudoku puzzles (up to 25 x 25) each of the 625 boxes may require as many as 25 label boxes. How can I create them programatically.

Thank you
JoeBBB
↧

Create Command Button to Copy Cell Value and Open a URL

August 18, 2017, 8:56 am
$
0
0
I need to create a button that will do the following, depending on a simple formula:
A. if FALSE: Copy the value of a cell to the clipboard
B. if TRUE: Copy the value of a cell to the clipboard AND open a URL in the default browser window

This will need to work on Excel on a PC or Mac

I was able to copy to clipboard using this VBA:
Sub RectangleRoundedCorners2_Click()
Range("C16:D16").Copy
End Sub

Please help!
↧
Viewing all 49962 articles
Browse latest View live
Search