I'm trying to make a macro where I can find a set of products and get an average weekly sales figure. However, FormulaR1C1 is only applying to the first figure in a selection and not all active cells. Any help as to why it doesn't apply for the whole range?
Option Compare Text
Private Sub submit_Click()
Dim emptyRow As Long
Dim Rng As Range
Dim myCell As Object
Dim mySelection As Range
Range("R1:S1").Select
Range("R1:S1").Clear
ActiveCell.FormulaR1C1 = ""
emptyRow = WorksheetFunction.CountA(Range("R:R")) + 1
Cells(emptyRow, 18).Value = search.Value
Cells(emptyRow, 19).Value = week.Value
Set Rng = Range("A1:A2000")
searchString = Range("R1")
For Each myCell In Rng
If InStr(myCell.Text, searchString) Then
If Not mySelection Is Nothing Then
Set mySelection = Union(mySelection, myCell)
Else
Set mySelection = myCell
End If
End If
Next
If mySelection Is Nothing Then
MsgBox "The product was not found in the selection"
Else
mySelection.Offset(0, 4).Select
End If
ActiveCell.FormulaR1C1 = "=RC[-2] /" & Range("S1")
Unload Me
End Sub
The selection may contain more than one cell, but only one is the active cell.
If mySelection Is Nothing Then
MsgBox "The product was not found in the selection"
Else
mySelection.Offset(, 4).FormulaR1C1 = "=RC[-2] /" & Range("S1")
End If
Related
I am working to create an add on style sheet to my company timesheet that will autofill company paid holidays by just the user inserting the dates. I use formulas on the excel timesheets to autofill the dates for the entire year so that I save time doing my bi-weekly payroll form. I have a holiday sheet that I name the holidays and input the date they are observed. The code is supposed to search all worksheets in the workbook until it finds the date for the corresponding holiday and input the number of hours off, the holiday code and name. The code I have written will find any date I insert up to 11/9/2022 and after this date it will not find any further dates. I have tried many things including changing the date column format, using different criteria settings for the .Find and even removing the formula from the date column and actually writing in 11/11/2022 and it is still unable to locate the date while using .Find. Please any help would be appreciated. I have added a few screens and code snippets of what I have so far.
Sub VeteransDay()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Holiday").Range("B9").Value
If Trim(FindString) <> "" Then
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
With ws.UsedRange
Set Rng = .Find(What:=FindString, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not Rng Is Nothing Then
sheetName = ws.Name
Cell_Add = Split(Rng.Address, "$")
ThisCol = Cell_Add(1)
ThisRow = Cell_Add(2)
Worksheets(sheetName).Range("K" & ThisRow).Value = 8
Worksheets(sheetName).Range("K" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("L" & ThisRow).Value = "HD"
Worksheets(sheetName).Range("L" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("M" & ThisRow).Value = Range("A9")
Worksheets(sheetName).Range("M" & ThisRow).Font.Color = vbRed
Exit Sub
End If
End With
End If
Next ws
End If
End Sub
enter image description here
enter image description here
Try this, the search is restricted to the range B1:B37 on each sheet.
Option Explicit
Sub VeteransDay()
Dim ws As Worksheet, ar, r
Dim dt As Date, sName As String, n As Long
Dim arHoliday, lastrow As Long, i As Long
With Sheets("Holiday")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
arHoliday = .Range("A1:B" & lastrow).Value
End With
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
' loop through holidays
For i = 1 To UBound(arHoliday)
dt = arHoliday(i, 2)
r = Application.Match(CDbl(dt), ws.Range("B1:B37").Value2, 0)
If Not IsError(r) Then
'MsgBox ws.Name & " row " & r
With ws.Range("K" & r)
.Value = 8
.Offset(, 1) = "HD"
.Offset(, 2) = arHoliday(i, 1) ' col A
.Resize(, 3).Font.Color = vbRed
n = n + 1
End With
End If
Next
End If
Next ws
MsgBox n & " found for all dates", vbInformation
End Sub
I am new to this forum, so bear with me.
I have a CSV-file that I need to apply some VBA-modules to in order to get the information I need.
In short, I have 3 macros that together to the following:
Create a new row every 20th row
Take the number from the cell above (column A) and fill the blank space in the new row with this number.
Sum the numbers in column H from the 20 rows before the new row to get a total score. This is done subsequently for as long as new rows appear (every 20th row).
Is it possible to get these three macros in a single macro? This would make it easier to hand down to others that may need to use these macros.
Current code:
' Step 1
Sub Insert20_v2()
Dim rng As Range
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
End Sub
' Step 2
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
' Step 3
Sub AutoSum()
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub
Thank you for any help.
Best,
Helge
You can create a single Sub calling all the other subs that you have created.
Example:
Sub DoAllTasks()
Insert20_v2
FillBlanks
AutoSum
End Sub
Then you just have to create a button and assign the DoAllTasks to it or run the macro directly.
HTH ;)
That Should'nt be that hard.
Public Sub main()
'deklaration
Dim rng As Range
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
'Loop trough all Rows
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
'Fill the Blank Rows in A
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub
I've created a Table from the range A112:H206, with days of the week (sunday, monday, etc) heading the table row from B112-H112. In column A, I have names of individuals listed going all the way down to A206.
I have an input section at the top of the spreadsheet, where a user will select a name from a drop down menu in cell A109, a day of the week from a drop down menu in cell B2, and finally a value in cell C109 which should be inputted in the corresponding cell in the table.
I created a button named "Enter" to which upon clicking should search for the corresponding cell based on the input section above, and input the C109 Value in that cell. Unfortunately my attempts using VBA were unsuccessful! Any help would be greatly appreciated.
Thank you!
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet
Dim x As Range
Dim y As Range
Dim valX, valY
Set ws1 = Sheets("Sheet1")
valX = ws1.Range("B2").Value
Set x = ws1.Range("A112:H112").Find(What:=valX, LookIn:=xlValues, _
lookat:=xlWhole)
If x Is Nothing Then
MsgBox "'" & valX & "' not found on '" & ws1.Name & "' !"
Exit Sub
End If
valY = ws1.Range("A109").Value
Set y = ws1.Range("A112:A206").Find(What:=valY, LookIn:=xlValues, _
lookat:=xlWhole)
If Not y Is Nothing Then
Range("C109").Select
Selection.Copy
ws1.Cells(x.Column, y.Row).Select
ActiveSheet.Paste
Range("C109").Select
Selection.ClearContents
Exit Sub
End If
End Sub
A friend of mine helped, I wanted to post it here just for reference for others!
Range("C109").Select
Selection.Copy
Dim Day As String
Dim Name As String
Dim nameFound As Boolean
Dim dayFound As Boolean
Name = Cells(109, "A").Value
Day = Cells(2, "B").Value
Range("A113").Select
nameFound = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = Name Then
nameFound = True
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If nameFound = True Then
Dim nameAddress As Integer
nameAddress = ActiveCell.Row
Else
MsgBox "Name not found"
End If
Range("B112").Select
dayFound = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = Day Then
dayFound = True
Exit Do
End If
ActiveCell.Offset(0, 1).Select
Loop
If dayFound = True Then
Dim dayAddress As Integer
dayAddress = ActiveCell.Column
Else
MsgBox "Day not found"
End If
Cells(nameAddress, dayAddress).Select
ActiveSheet.Paste
If ActiveCell.Column = 2 Or ActiveCell.Column = 4 Or ActiveCell.Column = 6 Or ActiveCell.Column = 8 Then
ActiveCell.Interior.Color = RGB(83, 142, 213)
ElseIf ActiveCell.Column = 3 Or ActiveCell.Column = 5 Or ActiveCell.Column = 7 Then
ActiveCell.Interior.Color = RGB(182, 221, 232)
End If
Range("C109").Select
Selection.ClearContents
Untested:
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet
Dim x As Range
Dim y As Range
Dim valX, valY
Set ws1 = Sheets("Sheet1")
valX = ws1.Range("A109").Value
Set x = ws1.Range("A112:H112").Find(What:=valX, LookIn:=xlValues, _
lookat:=xlWhole)
If x Is Nothing Then
MsgBox "'" & valX & "' not found on '" & ws1.Name & "' !"
Exit Sub
End If
valY = ws1.Range("B2").Value
Set y = ws1.Range("A112:A206").Find(What:=valY,LookIn:=xlValues, _
lookat:=xlWhole)
If Not y Is Nothing Then
With ws1.Range("C109")
.Copy ws1.Cells(y.Row, x.Column)' <<EDITED
.ClearContents
End With
Else
MsgBox "Name '" & valY & "' not found on '" & ws1.Name & "' !"
End If
End Sub
I have been driving myself mad with this for a day, searched high and low, and am probably trying to be too cute so am totally stuck.
I am trying to run a simple if then
If a cell contains "%" I'd like it to do one thing, and if not another. For reasons I don't understand I can't get it to work out. I've clearly taken a couple ideas from elsewhere but still can't get it to work.
Complicating factors- I don't want to run this on the whole column, just a table, so it is embedded in a larger sub using lots or relative ActiveCells. I never know where in the A column I am going to run into the "% Change" so the Range always has to be variable. I want VBA/VBE to do something different when it comes upon a cell with the "%" in it. SO
Here is what the raw data looks like
Initial Value (6/30/06)
Value (12/31/06)
Net Additions (9/30/07)
Withdrawal (12/07)
Value (12/31/07)
Withdrawal (2008)
Value (12/31/08)
Addition (8/26/09)
Value (12/31/09)
Value (12/31/10)
Value (12/30/11)
Value (3/31/12)
% Change 1st Quarter
% Change Since Inception
But when I run the following it gets stuck in a bad loop where it should have pulled out into the "If Then" as opposed to the "Else" part of the sub.
Sub IfTest()
'This should split the information in a table up into cells
Dim Splitter() As String
Dim LenValue As Integer 'Gives the number of characters in date string
Dim LeftValue As Integer 'One less than the LenValue to drop the ")"
Dim rng As Range, cell As Range
Set rng = ActiveCell
Do While ActiveCell.Value <> Empty
If InStr(rng, "%") = True Then
ActiveCell.Offset(0, 0).Select
Splitter = Split(ActiveCell.Value, "% Change")
ActiveCell.Offset(0, 10).Select
ActiveCell.Value = Splitter(1)
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = "% Change"
ActiveCell.Offset(1, -9).Select
Else
ActiveCell.Offset(0, 0).Select
Splitter = Split(ActiveCell.Value, "(")
ActiveCell.Offset(0, 9).Select
ActiveCell.Value = Splitter(0)
ActiveCell.Offset(0, 1).Select
LenValue = Len(Splitter(1))
LeftValue = LenValue - 1
ActiveCell.Value = Left(Splitter(1), LeftValue)
ActiveCell.Offset(1, -10).Select
End If
Loop
End Sub
All help is appreciated, thank you!
I simplified your code to isolate the test for "%" being in the cell. Once you get that to work, you can add in the rest of your code.
Try this:
Option Explicit
Sub DoIHavePercentSymbol()
Dim rng As Range
Set rng = ActiveCell
Do While rng.Value <> Empty
If InStr(rng.Value, "%") = 0 Then
MsgBox "I know nothing about percentages!"
Set rng = rng.Offset(1)
rng.Select
Else
MsgBox "I contain a % symbol!"
Set rng = rng.Offset(1)
rng.Select
End If
Loop
End Sub
InStr will return the number of times your search text appears in the string. I changed your if test to check for no matches first.
The message boxes and the .Selects are there simply for you to see what is happening while you are stepping through the code. Take them out once you get it working.
you never change the value of rng so it always points to the initial cell
copy the Set rng = rng.Offset(1, 0) to a new line before loop
also, your InStr test will always fail
True is -1, but the return from InStr will be greater than 0 when the string is found. change the test to remove = True
new code:
Sub IfTest()
'This should split the information in a table up into cells
Dim Splitter() As String
Dim LenValue As Integer 'Gives the number of characters in date string
Dim LeftValue As Integer 'One less than the LenValue to drop the ")"
Dim rng As Range, cell As Range
Set rng = ActiveCell
Do While ActiveCell.Value <> Empty
If InStr(rng, "%") Then
ActiveCell.Offset(0, 0).Select
Splitter = Split(ActiveCell.Value, "% Change")
ActiveCell.Offset(0, 10).Select
ActiveCell.Value = Splitter(1)
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = "% Change"
ActiveCell.Offset(1, -9).Select
Else
ActiveCell.Offset(0, 0).Select
Splitter = Split(ActiveCell.Value, "(")
ActiveCell.Offset(0, 9).Select
ActiveCell.Value = Splitter(0)
ActiveCell.Offset(0, 1).Select
LenValue = Len(Splitter(1))
LeftValue = LenValue - 1
ActiveCell.Value = Left(Splitter(1), LeftValue)
ActiveCell.Offset(1, -10).Select
End If
Set rng = rng.Offset(1, 0)
Loop
End Sub
For a search routine you should look to use Find, AutoFilter or variant array approaches. Range loops are nomally too slow, worse again if they use Select
The code below will look for the strText variable in a user selected range, it then adds any matches to a range variable rng2 which you can then further process
Option Explicit
Const strText As String = "%"
Sub ColSearch_DelRows()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim strFirstAddress As String
Dim lAppCalc As Long
'Get working range from user
On Error Resume Next
Set rng1 = Application.InputBox("Please select range to search for " & strText, "User range selection", Selection.Address(0, 0), , , , , 8)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
With Application
lAppCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , False)
'A range variable - rng2 - is used to store the range of cells that contain the string being searched for
If Not cel1 Is Nothing Then
Set rng2 = cel1
strFirstAddress = cel1.Address
Do
Set cel1 = rng1.FindNext(cel1)
Set rng2 = Union(rng2, cel1)
Loop While strFirstAddress <> cel1.Address
End If
If Not rng2 Is Nothing Then
For Each cel2 In rng2
Debug.Print cel2.Address & " contained " & strText
Next
Else
MsgBox "No " & strText
End If
With Application
.ScreenUpdating = True
.Calculation = lAppCalc
End With
End Sub
I have some problems with a piece of code. I get an error when it has to select a range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim valrand As Long
If Intersect(Target, ActiveCell) = "Insert line" Then
valrand = ActiveCell.Row
If Worksheets("IR").Cells(valrand, 18).Value <> 5 Then
Sheets("Format").Select
MsgBox ("Format")
Range("A13:N13").Select 'here's the error
Selection.Copy
Sheets("IR").Select
Range("A" & valrand + 2 + Worksheets("IR").Cells(12, 18) & ":N" & valrand + 2 + Worksheets("IR").Cells(12, 18)).Select
Selection.Insert Shift:=xlDown
Range("A38:N38").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A5").Select
contor = Worksheets("IR").Cells(12, 18).Value + 1
Worksheets("IR").Cells(12, 18).Value = contor
End If
End If
End Sub
Where I put the commet "here's the error" it gives me "Select method of Range class failed"
What am I doing wrong? Usually this piece of code worked before I added in the SelectionChange code block.
Thanks!
You should look at avoiding Select when using Sheet code (best to avoid it altogether, more later on this) and use something like this instead
Application.Goto Sheets("Format").Range("A13:N13")
(I had tried fully qualifying the reference but this only worked if I used
Sheets("Format").Select
Sheets("Format").Range("A13:N13").Select
which is clearly overkill)
While that solves you immediate issue you should look at consolidating your code, for example
Disabling Events so that other sheet events dont fire while your Select is running
Removing any Select statements
This is an example of what may work better (now with no sheet activation)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lngRand As Long
Dim rng1 As Range
Set ws1 = Sheets("Format")
Set ws2 = Sheets("IR")
If Intersect(Target, ActiveCell) = "Insert line" Then
lngRand = ActiveCell.Row
If ws2.Cells(lngRand, 18).Value <> 5 Then
Application.EnableEvents = False
Set rng1 = Range("A" & lngRand + 2 + ws2.Cells(12, 18))
'extend rng1 from column A to colum N
Set rng1 = rng1.Resize(rng1.Rows.Count, 14)
ws2.Range(rng1.Address).Insert xlDown
'copy Format to IR
ws1.Range("A13:N13").Copy ws2.Range(rng1.Address)
'Update Format
ws2.Range("A38:N38").Delete Shift:=xlUp
ws2.Cells(12, 18).Value = ws2.Cells(12, 18).Value + 1
Application.EnableEvents = True
End If
End If
End Sub