I am wondering if it is possible to replicate my code 30 times with slight variations to FIND function, finding different items "New Food Price, New Pizza Price, New Seafood Price.. Etc"
If I was to copy the whole code 34 times it would be extremely long, and if anything changed I would have to change it 34 times. Is it at all possible to repeat majority of the code 34 times and just change the FIND word & Formulas that are pasted?
Dim rng As Range
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("A1:FF1")
Set rFind = .Find(What:="US", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
LastColumn = rFind.Column
End If
End With
Set rng = Range(Cells(2, LastColumn), Cells(2, LastColumn + 7))
final_Column = Application.Match("New Food Price", rng, 0)
LastColumn = LastColumn + final_Column
Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Cells(2, LastColumn).Select
ActiveCell.Value = "New Food Price"
ActiveCell.Interior.ColorIndex = 22
Range(Cells(3, (LastColumn)), Cells(LR, (LastColumn))).Formula = "=(5)"
LastColumn = LastColumn + 1
Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Cells(2, LastColumn).Select
ActiveCell.Value = "Difference"
ActiveCell.Interior.ColorIndex = 22
Range(Cells(3, (LastColumn)), Cells(LR, (LastColumn))).Formula = "=(6)"
Set rng = Range(Cells(2, LastColumn), Cells(2, LastColumn + 7))
final_Column2 = Application.Match("New Wine Price", rng, 0)
LastColumn = LastColumn + final_Column2
Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Cells(2, LastColumn).Select
ActiveCell.Value = "New Wine Price"
ActiveCell.Interior.ColorIndex = 22
Range(Cells(3, (LastColumn)), Cells(LR, (LastColumn))).Formula = "=(5)"
LastColumn = LastColumn + 1
Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Cells(2, LastColumn).Select
ActiveCell.Value = "Difference"
ActiveCell.Interior.ColorIndex = 22
Range(Cells(3, (LastColumn)), Cells(LR, (LastColumn))).Formula = "=(6)"
Here you go!
Sub SearchAll()
Dim SearchTerms As Variant
SearchTerms = Array("US", "UK", "BR")
For Each SearchTerm In SearchTerms
Search SearchTerm
Next
End Sub
Sub Search(SearchTerm)
Dim rng As Range
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("A1:FF1")
Set rFind = .Find(What:=SearchTerm, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
LastColumn = rFind.Column
End If
End With
...
...
End Sub
And a short explanation, as requested:
The first Sub creates an array of search terms. It is then stepped through, using a For Each. For each value the Search method is called with one parameter. This parameter is then used in the Find call.
Related
I want to do a dynamic sum formula in VBA and it's some how very difficult for me because I don't use well integer variables.
the last row might change in the future and I need that the range will be dynamic.
thanks to those who will help me.
Sub SumColumns()
Sheets("data").Select
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.Value = "sum"
Selection.Interior.ColorIndex = 33
Selection.Font.Bold = True
Dim LastCol As Integer
Dim LastRow As Integer
With Sheets("data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Range("A1").End(xlDown).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=SUM(R[- " & LastRow & " + 1]C:R[-1]C)"
Selection.AutoFill Destination:=Range("B" & LastRow, "I" & LastRow), Type:=xlFillDefault
End Sub
that is the line with the error:
ActiveCell.FormulaR1C1 = "=SUM(R[- " & LastRow & " + 1]C:R[-1]C)"
Take the + 1 out of the quotes as that seems to be causing the problem and you need to deduct 1 otherwise you will be on row zero. The code below also removes your selects which are unnecessary and inefficient. And use your LastCol variable to determine across how many columns to copy the formula.
Sub SumColumns()
Dim LastCol As Long 'use Long rather than Integer
Dim LastRow As Long
With Sheets("data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A" & LastRow + 1)
.Value = "sum"
.Interior.ColorIndex = 33
.Font.Bold = True
End With
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("B" & LastRow + 1).Resize(, LastCol - 1).FormulaR1C1 = "=SUM(R[-" & LastRow - 1 & "]C:R[-1]C)"
End With
End Sub
You can get rid of many select portions and steam line code like below. Test it and see if this is what you are after.
Sub SumColumns()
Dim LastCol As Long
Dim LastRow As Long
With Sheets("data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range("A" & LastRow).Offset(1, 0)
.Value = "SUM"
.Interior.ColorIndex = 33
.Font.Bold = True
End With
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow).Offset(0, 1).FormulaR1C1 = "=SUM(R[-" & LastRow - 1 & "]C:R[-1]C)"
.Range("A" & LastRow).Offset(0, 1).AutoFill Destination:=.Range("B" & LastRow, .Cells(LastRow, LastCol)), Type:=xlFillDefault
.Range("A" & LastRow, .Cells(LastRow, LastCol)).Borders.LineStyle = xlContinuous
.Range("A" & LastRow, .Cells(LastRow, LastCol)).Borders.Weight = xlThin
End With
End Sub
How can I highlight a single row a color if text in column A = X
Using Row 4 as an example:
What i'm ultimately trying to get is if Cell in Column A is = X then change row color from Range("B4:N4") to Black And Text.Color to White from Range("F4:N4")
Ultimately I would want it to be something like Range(Cells(i, "B"), Cells(LastRow, LastCol)) but only color one row.
This is what i am working with so far.
Sub Header()
Application.ScreenUpdating = False
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("Email Form")
sht2.Activate
sht2.Unprotect
Dim LastRow As Long, LastCol As Long
Dim rng As Range, c As Range
Dim WholeRng As Range
Dim i As Integer
On Error GoTo 0
With sht2
Set rng = .Cells
LastRow = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
LastCol = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
'MsgBox wholerng.Address
Set WholeRng = Range(Cells(i, "B"), Cells(LastRow, LastCol)).Rows
For i = 4 To LastRow
If sht2.Cells(i, 1).Value = "X" Then
With WholeRng
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 1
.TintAndShade = 0
.Font.Color = 0
End With
End With
End If
Next i
Dim b As Boolean
For Each rng In WholeRng.Rows
If Not rng.Hidden Then
If b Then rng.Interior.Color = 1
b = Not b
End If
Next
End With
Set sht2 = Nothing
Set rng = Nothing
Set WholeRng = Nothing
Application.ScreenUpdating = False
End Sub
VBA Conditional Formatting.
Option Explicit
Sub Header()
Dim sht2 As Worksheet
Dim firstRow As Long, lastRow As Long, lastCol As Long
'Application.ScreenUpdating = false
On Error GoTo 0
Set sht2 = ThisWorkbook.Worksheets("Email Form")
firstRow = 4
With sht2
.Activate
.Unprotect
lastRow = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
'black row, white text B:N
With .Range(.Cells(firstRow, "B"), .Cells(lastRow, lastCol))
'optionally remove any pre-existing CFRs
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=UPPER($A4)=CHAR(88)")
.Interior.ThemeColor = xlThemeColorLight1
.Font.ThemeColor = xlThemeColorDark1
.SetFirstPriority
.StopIfTrue = False
End With
End With
'don't display values from B:E
With .Range(.Cells(firstRow, "B"), .Cells(lastRow, "E"))
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=UPPER($A4)=CHAR(88)")
.NumberFormat = ";;;"
End With
End With
'I tnhink you want to reProtect the worksheet here
.Protect
End With
Application.ScreenUpdating = True
End Sub
I think you can achieve your goal using Conditional Formatting:
You can create a condition for each format setting for the two different ranges.
Select one range at a time, then from the Home tab, create a New Conditional Formatting Rule, choose to Use a Formula and then enter a formula like:
=$A2="X"
Note that when using relative/mixed references in conditional formatting, it will be compared to the first cell in the range you are working with. I've selected range B2:N7 to apply formatting to, so the mixed reference needs to be created as it should apply to the B2 cell. You can't see it, but the reference automatically changes for all other cells in the same range, the same as if you were filling a formula across the rest of the range. For example, the formatting for the K5 cell will be dependent on the value in $A5 (because the column reference is fixed but the row reference is dynamic).
Then set the background colour or font colour you want for the range specified. This condition will check column A of the corresponding row.
I re-wrote some of your code and added comments to show you why. But by and large, I followed your original approach.
Sub Header()
Dim Sht2 As Worksheet
Dim LastRow As Long, LastCol As Long
Dim IsBlack As Boolean, FillPattern As Long
Dim Rng As Range
Dim R As Long
' Set sht2 = ThisWorkbook.Worksheets("Email Form")
Set Sht2 = ThisWorkbook.Worksheets("Taylor")
' On Error GoTo 0 ' this is the default: no need to set
Application.ScreenUpdating = False
With Sht2
.Activate ' no need to activate this sheet
.Unprotect
' this is the whole sheet: Easier to refer to it as .Cells
' Set rng = .Cells
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' LastRow = Rng.Find(What:="*", After:=Rng.Cells(1), Lookat:=xlPart, _
' LookIn:=xlFormulas, SearchOrder:=xlByRows, _
' SearchDirection:=xlPrevious, MatchCase:=False).Row
' LastCol = Rng.Find(What:="*", After:=Rng.Cells(1), Lookat:=xlPart, _
' LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
' SearchDirection:=xlPrevious, MatchCase:=False).Column
' MsgBox "Last row = " & LastRow & vbCr & _
' "Last column = " & LastCol
For R = 4 To LastRow
IsBlack = Not CBool(StrComp(.Cells(R, 1).value, "X", vbTextCompare))
FillPattern = CLng(Array(xlNone, xlSolid)(Abs(IsBlack)))
Set Rng = .Range(.Cells(R, 1), .Cells(R, LastCol))
With Rng.Interior
If .Pattern <> FillPattern Then
.Pattern = FillPattern
If IsBlack Then
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
End If
.TintAndShade = 0
.PatternTintAndShade = 0
Rng.Font.ColorIndex = Array(xlAutomatic, 2)(Abs(IsBlack))
End If
End With
Next R
End With
' VBA does this cleanup automatically at the end of the sub
' Set sht2 = Nothing
' Set Rng = Nothing
Application.ScreenUpdating = False
End Sub
my concept is first i have to enter text as Engine in excel at (12,3) then from g13 to end column have to search for 0,* if it is found that particular column containing 0 or * should read the value present in the 3 and 4th row text value and it should be placed at (13,3) I HAVE explained the concept in image file spreadsheet image i have also written code but the result is not up to the level please help in this project .
Dim searchRange As Range
Dim C As Range
Dim FinalRow As Range
Dim firstaddress As String
With Cells(12, 3)
.Value = "Engine"
.Font.Size = 14
.Font.Bold = True
End With
Dim lastrow As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lastColumn As Integer
lastColumn = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
For i = 13 To lastrow
Set searchRange = Range("G13:ZZ20000")
Set Rng = searchRange.Find(What:="0", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
firstaddress = Rng.Address
Rng.Offset(i, -5).Value = Rng.Offset(-11, ActiveCell.Column).Value
Next i
with regards,
karthikeyan
you could try this
Option Explicit
Sub main()
Dim cell As Range
Dim lastrow As Long, lastColumn As Long, i As Long
Dim strng As String, resStrng As String
With ActiveSheet
With .Cells(12, 3)
.Value = "Engine"
.Font.Size = 14
.Font.Bold = True
End With
lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
lastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
For i = 13 To lastrow
resStrng = ""
For Each cell In .Range(.Cells(i, "G"), .Cells(i, lastColumn))
If cell.Value = "*" Or cell.Value = 0 Then
strng = .Cells(2, cell.Column) & .Cells(3, cell.Column)
If InStr(resStrng, strng) = 0 Then resStrng = resStrng & strng & "&"
End If
Next cell
If resStrng <> "" Then .Cells(i, 3) = Left(resStrng, Len(resStrng) - 1)
Next i
End With
End Sub
I have the following that is placing a simple Vlookup into a cell.
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-25],[MasterFood.xlsx]Sheet1!C1:C6,6,0),0)"
I'm needing to replace the -25 with the a variable (called LastColumn) which has already been calculated as the column number will change everytime the program is run. The full part of the code is below
Dim LastColumn As Integer
If WorksheetFunction.CountA(Cells) > 0 Then
LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Cells(1, LastColumn + 1).Select
ActiveCell.FormulaR1C1 = "ORDER"
End If
Cells(2, LastColumn + 1).Select
'Define Categories
For z = 2 To RowCount - 1
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-25],[MasterFood.xlsx]Sheet1!C1:C6,6,0),0)"
ActiveCell.Offset(1, 0).Select
Next
Any ideas please?
Here you go:
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[" & LastColumn & "],[MasterFood.xlsx]Sheet1!C1:C6,6,0),0)"
I'm trying to read every line in one sheet (Get_Command) and looking for the value in the first column in an another sheet (Command_List); if this value is in the Command_List I want to copy the line (deleting some columns) to a third sheet (Set_Command).
Sub Macro1()
'
' Macro1 Macro
'
Dim fnFormat As Range
Dim c As Long
Dim MyCol As Long
Dim fCommand As Range
Dim Command As String
With Sheets("Get_Command")
.Select
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = 1 To Lastrow Step 1
Command = Cells(Lrow, 1).Value
Set fCommand = Worksheets("Command_List").Columns("A:A").Find(Command, LookIn:=xlValues)
If Not fCommand Is Nothing Then
Lastcolumn = .Cells(Lrow, .Columns.Count).End(xlToLeft).Column
Range("A" & Lrow).Select
Selection.Copy
Sheets("Set_Command").Select
Range("A" & Lrow).Select
ActiveSheet.Paste
ActiveSheet.Columns("A").Replace What:="Get:", Replacement:="Set", LookAt:=xlPart, SearchOrder:=xlByColumns
Application.CutCopyMode = False
Sheets("Get_Command").Select
Set fnFormat = Range(Cells(Lrow, 5), Cells(Lrow, Lastcolumn)).Find("nFormat", LookIn:=xlValues)
If fnFormat Is Nothing Then 'If it is not found
c = 1
For Lcolumn = 5 To Lastcolumn Step 2
Cells(Lrow, Lcolumn).Select
Selection.Copy
Sheets("Set_Command").Select
c = c + 1
Cells(Lrow, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Get_Command").Select
Next Lcolumn
Else
c = 1
'It should remove "(", ")", "," and the columns that a don't need
For Lcolumn = 5 To fnFormat.Column - 3 Step 2
Cells(Lrow, Lcolumn).Select
Selection.Copy
Sheets("Set_Command").Select
c = c + 1
Cells(Lrow, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Get_Command").Select
Next Lcolumn
For Lcolumn = fnFormat.Column + 3 To Lastcolumn Step 2
Cells(Lrow, Lcolumn).Select
Selection.Copy
Sheets("Set_Command").Select
c = c + 1
Cells(Lrow, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Get_Command").Select
Next Lcolumn
End If
End If
Next Lrow
End With
End Sub
The problem is on:
Command = Cells(Lrow, 1).Value
Set fCommand = Worksheets("Command_List").Columns("A:A").Find(Command, LookIn:=xlValues)
The Command is saving what I want, but fCommand is returning always Nothing.
Could someone help me to find my error?
Thanks! =)
Find returns Nothing when it does not find a matchin cell. So you have problem with the data that you are using. Potential source for your problem:
there are leading or trailing spaces in your command or in the list of possible commands
you are referencing the wrong range in Find