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

Post formula and values to last row in Col A,B,C

$
0
0
Hi All,

I am trying to post formulas, strings and values to various columns in the last row. I have offset by 1 row to find the empty cell but still no luck. Any help appreciated...

Thanks!

Code:

With wbmaster
    .Sheets("HH").Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Formula = "=INT((TODAY()-1)/7)*7+1"
    .Sheets("HH").Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = "Raw"
    .Sheets("HH").Range("C" & .Rows.Count).End(xlUp).Offset(1, 0).Value = ThisWorkbook.Sheets(1).Range("C2:T2")
End With


Trying to compare two non adjacent columns in sheet2 to two non adjacent columns in sheet1

$
0
0
Hi all, I am new to this forum and very new to VBA! I am trying to help my wife with a spreadsheet she uses a lot. Basically I need to find a row in sheet 1 (Tracking) where Column B is the same in both and where column G in sheet 2 (BL) matches column D in sheet 1, and if so, update the data in sheet 1 column E with the data from sheet 2 column H. And then highlight any rows in sheet 2 which did not match....

Now thanks to some code that I found on the Internet I have managed to do most of this but I cannot figure out how to do the second comparison, sheet 2 column G to sheet 1 column D. :confused: Can anyone help?? It would be greatly appreciated. My code for the bit that doesn't work is below:

Code:

Sub OverwriteMatchedData()

Dim sID As Range, whattofind As Range, i As Long
Dim mSh As Worksheet, sSh As Worksheet

Set mSh = Worksheets("Tracking")
Set sSh = Worksheets("BL")

For i = 2 To 25
  Set whattofind = sSh.Range("B2,G2" & i)
  With mSh
    Set sID = .Range("B:B,D:D").Find(What:=whattofind.Value2, After:=.Range("B" & .Rows.Count))
   
    If Not sID Is Nothing Then
 
    sID.Offset(, 3) = whattofind.Offset(, 7)

    End If
  End With
  Set sID = Nothing
  Set whattofind = Nothing
Next
MsgBox "Matches updated", vbOKCancel
End Sub

Attached Files

what could be wrong?

$
0
0
I have a problem with code supposed to track my invoices and make a record for every invoice in another sheet in the same workbook ,but it dose not work for some reason?
here is the code
Code:

Sub InvoiceReport()
Dim myFile As String, lastRow As Long
lastRow = Sheets("Sheet2").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
'Transfer data to Sheet2
Sheets("Sheet2").Cells(lastRow, 1) = Sheets("Sheet1").Range("f3")
Sheets("Sheet2").Cells(lastRow, 2) = Sheets("Sheet1").Range("d3")
Sheets("Sheet2").Cells(lastRow, 3) = Sheets("Sheet1").Range("d6")
Sheets("Sheet2").Cells(lastRow, 4) = Sheets("Sheet1").Range("d7")
Sheets("Sheet2").Cells(lastRow, 5) = Sheets("Sheet1").Range("c9")
Sheets("Sheet2").Cells(lastRow, 6) = Sheets("Sheet1").Range("f14")
Sheets("Sheet2").Cells(lastRow, 7) = Sheets("Sheet1").Range("f15")
Sheets("Sheet2").Cells(lastRow, 8) = Sheets("Sheet1").Range("f16")

End Sub

if folder = recycle bin then skip

$
0
0
I have a macro that loops through folder and subfolders.
But if I select the root of a harddrive like E:/
I get a error with access denied when it gets to E:/ recycle.bin

How can I skip this?

Excel VBA Timer

$
0
0
Hi All, I have been some digging, but can't seem to find what I am looking for in regards to a count-down timer. What I would like to do is to be able to set up 10+ countdown timers on a single page with a start/stop/pause button.

Each timer might be for a different time, say 15 minutes, 20 minutes, 1 hour, etc. Each would need it's own control button and hopefully make a noise when it counts down to 0.

is this possible? If so, any hints or tips on where to find it.

All the best, Frank

[SOLVED] How to write "IF Target column = Odd Then"

$
0
0
Hello there,

I am pretty new to VBA so I know this is a simple question, but what is an efficient way to code the line:

"If Target.Column that changed is odd then..."

Currently in my Worksheet_Change I have the clunky code:

"If Target.Column = 1 Or Target.Column = 3 Or ..... Target.Column = 99 Then".

What would be the correct way to do this?

Thank you!

copy file(s) from folder and / or subfolders to desktop folder

$
0
0
All....hope you can help as cant find how to do this!!!

I have one folder which may or may not have subfolders. lets say C:\Users\fred\Documents\Attachments\reports

In this set up there will be a file called test.txt.

I would like a macro, to search this entire folder setup including subfolders and copy this file to a pre-setup folder on the desktop called Results, and then delete all the original subfolders.

Hope you expects can assist!

Skyping

Pivot table not created due to sheet reference

$
0
0
Hello,

I have the below code to create a pivot table based off of a data set. It is a template that will be used going forward however the code references Sheets("Sheet33").Select in it. The problem with this is when I test and delete tabs and rerun the code the sheet is not Sheet 33 any longer. What can I put to make it dynamic? I have code that creates two pivot tables and they both have this problem.


Code:

Sub Dept76000Pivot()
'
' Dept76000Pivot Macro
'

'
    Dim LastRow6 As Long
    With Worksheets("76000 Original")
    Sheets("76000 Original").Select
    Sheets.Add
    LastRow6 = .Range("C" & Rows.Count).End(xlUp).Row
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "76000 Original!R4C1:R" & LastRow6 & "C21", Version:=6).CreatePivotTable _
        TableDestination:="Sheet32!R3C1", TableName:="PivotTable2", DefaultVersion _
        :=6
    Sheets("Sheet32").Select
    Cells(3, 1).Select
    End With
    With ActiveSheet.PivotTables("PivotTable2")
        .ColumnGrand = True
        .HasAutoFormat = True
        .DisplayErrorString = False
        .DisplayNullString = True
        .EnableDrilldown = True
        .ErrorString = ""
        .MergeLabels = False
        .NullString = ""
        .PageFieldOrder = 2
        .PageFieldWrapCount = 0
        .PreserveFormatting = True
        .RowGrand = True
        .SaveData = True
        .PrintTitles = False
        .RepeatItemsOnEachPrintedPage = True
        .TotalsAnnotation = False
        .CompactRowIndent = 1
        .InGridDropZones = False
        .DisplayFieldCaptions = True
        .DisplayMemberPropertyTooltips = False
        .DisplayContextTooltips = True
        .ShowDrillIndicators = True
        .PrintDrillIndicators = False
        .AllowMultipleFilters = False
        .SortUsingCustomLists = True
        .FieldListSortAscending = False
        .ShowValuesRow = False
        .CalculatedMembersInFilters = False
        .RowAxisLayout xlCompactRow
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotCache
        .RefreshOnFileOpen = False
        .MissingItemsLimit = xlMissingItemsDefault
    End With
    ActiveSheet.PivotTables("PivotTable2").RepeatAllLabels xlRepeatLabels
    Sheets("Sheet32").Select
    Sheets("Sheet32").Name = "76000"
    Sheets("76000").Select
    With ActiveWorkbook.Sheets("76000").Tab
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("GL String")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Debit"), "Sum of Debit", xlSum
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Credit"), "Sum of Credit", xlSum
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Company CO")
        .Orientation = xlColumnField
        .Position = 2
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Cost Center")
        .Orientation = xlColumnField
        .Position = 3
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Region")
        .Orientation = xlColumnField
        .Position = 4
    End With
    Sheets("76000").Select
    Sheets("76000").Move After:=Sheets(13)
End Sub


How do I get my macro to stop at the last row

[SOLVED] Loop Help

$
0
0
I have attached a sample workbook. Column A has data in it and column B has the desired calculation I am trying to have VBA calculate. I am trying to loop through column A, find when the cell isn't blank, sum all cells in a row that are not blank and subtract 3 from that sum. Whenever a cell in column A is not blank, there will be a 1 followed by at least 3 more 1s. The actual file I have is 20,000 + rows. Any advice would be highly appreciated.
Attached Files

Alternate colors based on value

$
0
0
Hi, I am looking for a macro that will go through column B (States) and when the state changes from one to another I would like to highlight the range - basically color coding when the list changes from one state to the next. Please see the example attached...
Attached Files

[SOLVED] Add Cancel in the message box

$
0
0
Hello all,
Is there anyway to add a "cancel" in this code?

I only see "OK" when a button is clicked.

Thanks.

Code:

Sub cmdSave_Click()
    ThisWorkbook.Save
    ThisWorkbook.Saved = True
    MsgBox "COMPLETELY SAVED!"
End Sub

PageBreak thru VBA, if cell = 1 - Works, BUT - if row hidden dosent work.

$
0
0
Hi all.

Hoping this forum once again can help me, once again.
I have this code part of a big sheet, it works, if all row are visible, in the range. This is the first short code.
The range in question is "For Each Cell In Range("A686,A1572,A2297,A2617,A2987,A3257,A3710,A4270,A4669,A5469,A5939,A6269,A6589,A6959,A7219,A7599,A7929")"

But as you can see from the long code, I have other factors where the long code, hide rows, and once this happen the short code stop working.
Any suggestions ?

I tried to add this code
Rows("686,1572,2297,2617,2987,3257,3710,4270,4669,5469,5939,6269,6589,6959,7219,7599,7929").EntireRow.Hidden = False
Still got error when running.

Looking forward to your reply :-)

/ Kristian


Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim row As Variant, hidrng As Range

    Dim Cell As Range
            ActiveSheet.ResetAllPageBreaks
    For Each Cell In Range("A686,A1572,A2297,A2617,A2987,A3257,A3710,A4270,A4669,A5469,A5939,A6269,A6589,A6959,A7219,A7599,A7929")
            If Cell.Value = 1 Then
                Cell.PageBreak = xlPageBreakManual
            ElseIf Cell.Value = "x" Then
                Cell.PageBreak = xlPageBreakNone
            End If
    Next Cell
End sub


This is the full code
Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim row As Variant, hidrng As Range
'    Dim KSPW As String
'    KSPW = "Password"
 '        ActiveSheet.Unprotect Password:=KSPW
 
 ' Ovf. fra Fxx antal af valgte forsikringer.
    If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("4:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 1).Value = "x" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
 
 ' Hvis nej vises row ikk
    If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("4:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 2).Value = "y" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
 
 ' Hvis b, vises ikke = ingen bemærkninger, kun fritekst.
  If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("1:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 3).Value = "b" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
   
' Hvis e, vises fritekst og bemærkninger ikke.
    If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("4:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 4).Value = "e" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If

' Disse 3 virker.
    Dim Cell As Range
            ActiveSheet.ResetAllPageBreaks
    For Each Cell In Range("A686,A1572,A2297,A2617,A2987,A3257,A3710,A4270,A4669,A5469,A5939,A6269,A6589,A6959,A7219,A7599,A7929")
            Selection.EntireRow.Hidden = False
            If Cell.Value = 1 Then
                Cell.PageBreak = xlPageBreakManual
            ElseIf Cell.Value = "x" Then
                Cell.PageBreak = xlPageBreakNone
            End If
    Next Cell
 
 ' Ovf. fra Fxx antal af valgte forsikringer.
    If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("4:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 1).Value = "x" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
 
 ' Hvis nej vises row ikk
    If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("4:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 2).Value = "y" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
 
 ' Hvis b, vises ikke = ingen bemærkninger, kun fritekst.
  If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("1:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 3).Value = "b" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
   
' Hvis e, vises fritekst og bemærkninger ikke.
    If Not Intersect(Target, Target.Parent.Range("A:A")) Is Nothing Then
        Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                ActiveSheet.Rows("4:9999").Hidden = False
                For Each row In ActiveSheet.UsedRange.Rows
                    If row.Cells(1, 4).Value = "e" Then
                        If hidrng Is Nothing Then Set hidrng = row Else Set hidrng = Union(hidrng, row)
                    End If
                Next row
            If Not hidrng Is Nothing Then hidrng.Rows.Hidden = True
                Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If

End Sub

[SOLVED] The Proper way to get rid of "Long Procedure" error

$
0
0
Dear all. My excel file with macro is attached. My problem is the current macro gives "Long Procedure" error if I extends the codes. The table is constant by rows & columns and can be pasted below around 20 times. The table is consist of 13 rows and will be pasted next to eachother as in the file. How can the code simplified to get rid of "Long Procedure" error to be able to use in maximum 20 tables?
Attached Files

Using patterns - capture text after a string

$
0
0
It is my first time to use patterns for capturing objects.

I cannot figure out what goes into the pattern in order to capture everything after "Details : Folders: ".

Example:
Cell value: Details : Folders: f1A795, f1B795, f2A795, f34955, fK683
Output: f1A795, f1B795, f2A795, f34955, fK683


My code below omits the first "f" and gives me this result: "1A795, f1B795, f2A795, f34955, fK683"

Code:

Set r = CreateObject("VBScript.RegExp")
    r.IgnoreCase = True
    r.Global = True
    r.Pattern = "[\Details : Folders: ]+"


Can you help?

How can I insert a row in Sheet1 from code in Sheet2 without Selecting Sheet 1 first?

$
0
0
My initial display is Sheet 1
When I click on the tab for Sheet 2, Sheet 2 is displayed and the Sheet 2 Activate code is run.



















I have no problem updating cell data in Sheet 1 from VBA code running in Sheet 2, but I also need to insert a row in Sheet1 from the VBA code in Sheet 2.

I've tried Selecting Sheet 1 from the code and then inserting a row. That works, but I then needed to return to working on Sheet 2. If I select Sheet 2 after inserting a row in Sheet 1, the Activation code for Sheet 2 runs, and that causes havoc!

So, how can I insert a row in Sheet 1 code in Sheet 2 without selecting Sheet 1 first?













Within the code for Sheet 2 I have this code to add a row to Sheet 1 and fill in the row.

XLSLastRow = XLSLastRow - 1
XLSLastRowDate = Format(Sheets("Sheet1").Cells(XLSLastRow, "A").Value, "yyyymmdd")
' If the last .xls file record date is < the Through Date,
' add a new last record by copying the last record and using the Through Date
If SelectedThroughDateYYYYMMDD > XLSLastRowDate Then
Sheets("Sheet1").Select
Sheets("Sheet1").Rows(XLSLastRow + 1).Select
Selection.Insert
Sheet1.Rows(XLSLastRow + 1).EntireRow.Value = Sheet1.Rows(XLSLastRow).EntireRow.Value
Sheets("Sheet1").Cells(XLSLastRow + 1, "A").Value = SelectedThroughDate
Sheets("Get Sign Data").Select
End If

The problem is I have to return to Sheet 2

Rt Click Context Menu - Modifying

$
0
0
.
I want to delete only the top portion of the Context Menu (right click pop up menu). See the image below.

After looking on the internet and this Forum and others all the resources show how to delete the entire menu then rebuild what you want.
I would rather NOT delete the entire menu. Just the top portion.

Thanks for reading and any assistance !

Context Menu.jpg

Selecting From Web Drop Down List with VBA

$
0
0
Hello all

I was hoping you can help with the following problem.

I am trying to use Excel VBA to select the value in a drop down box from a web page.

The code for the web page is as follows:-

tttttt.JPG

From the drop down list I have already selected what I wanted which translates to a value of 2875.

I am really struggling with the code, I have the following:-

Sub web_lists()

Dim ie As Object
Set ie = CreateObject("internetexplorer.application")
Dim doc As ie.document

ie.doc.getElementById("tic").Value = 2875

End Sub

I know this is wrong but I was copying and pasting bits from various different places on the web and after several hours I have gotton no where and need some help.

I am not entirely sure if I have selected all the correct references from the reference list box.

Can anyone help but also talk me through what the code does??

Really appreciate any support you can give.

Thank you.

Unable to get the WorksheetFunction.Linest working

$
0
0
Hi,

I have a problem with the linest function. I'm trying to get the Qudratic regression of a set of values and display it in a sheet. However I keep getting the error "Unable to get the linEst property of the WorksheetFunction Class". My code is:
Code:

Dim Xvals As Range
Dim Yvals As Range

Set Xvals = Worksheets("V Az or H El").Range("A2:A43")
Set Yvals = Worksheets("V Az or H El").Range("B2:B43")

Worksheets("V Az or H El").Range("B105:D105").FormulaArray = Application.WorksheetFunction.LinEst(Xvals, Yvals, [What do I add here?])

When I use the excel formula "=LINEST($B2:$B43,$A2:$A43^{1,2})" this works fine. I just can't figure out how to do the exact same thing using the LinEst function in VBA.

I am trying to write a macro/ formula that will combine 3 cells, hyphenate and add zero's

Viewing all 49872 articles
Browse latest View live