i'm trying to tweak my macro so that it creates a column next to a specific column that always changes positions. In the macro i have below, it is just an absolute reference of 6 columns to the left. However, this wont always be the case. Should I set this up by finding the column name in the top row?
Basically the macro creates a new column and puts in an IF statement if it is a duplicate, and then sets up conditional formatting to highlight all the values of "1". Sorry if i am not explaining this clearly!
Sub test()
Columns("L:L").Select
Selection.Insert Shift:=xlToRight
Range("L2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-6]=R[-1]C[-6],R[-1]C+1,1)"
Range("L2").Select
Selection.Copy
Range("K2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
I have a working code for this but it requires that your data be in a table. This is the best way to dynamically manipulate and reference the data (Columns, Rows, etc..)
Also I heavily rely on the ListObject method. It really handles tables well.
Public Sub InsertColumn(Optional columnName As String, Optional BeforeORAfter As String)
Dim loTableName As ListObject
Dim loColumn As ListColumn
Dim newColDest As Long
'Handles user input if they desire the column inserted before or after
Select Case UCase(BeforeORAfter)
Case Is = "BEFORE"
newColDest = 0 'Inserts column and moves reference column right
Case Else
newColDest = 1 'Inserts column to the right of reference column
End Select
'Ensures the user selects a reference column name
Select Case columnName
Case Is = ""
columnName = InputBox("Enter column name to be referenced.", "Enter Column Name")
Case Else
End Select
'Sets the ListObject as the table.
Set loTableName = Range("TableName").ListObject
With loTableName
On Error GoTo InsertError 'Exits sub in case the column couldn't be found
.ListColumns.Add (.ListColumns(columnName).Index + newColDest)
End With
Exit Sub
InsertError:
'Most likely error is user typed the column header incorrectly.
MsgBox "Error creating column. Ensure a correct reference column was chosen", vbExclamation + vbOKOnly, "Insert Error"
End Sub
Any questions or problems, just let me know.
This below would be something you can work with (it will ask the column to search and perform the actions in your recorded macro...
Check my website http://multiskillz.tekcities.com/k2500_0vbaMenu.html
Sub test_modified()
'worksheet workbook object
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
'range object to select a column
Dim fRng As Variant
fRng = Application.InputBox(Prompt:="value to find", Title:="InputBox Method", Type:=2)
'range object to find the column
Dim colRng As Range
Set colRng = ws.Rows(1)
'find column
Dim fcol As Range
Set fcol = colRng.Find(fRng, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
'convert the column address to a number
Dim colNb As Byte
colNb = fcol.Column
'going on from your recorded macro
'Columns("L:L").Select
ws.Columns(colNb).Select
Selection.Insert Shift:=xlToRight
Range("L2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-6]=R[-1]C[-6],R[-1]C+1,1)"
Range("L2").Select
Selection.Copy
Range("K2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
Cheers
Pascal
Related
I'm trying to create a VBA Macro to automate part of a large process. I can do it manually but it isn't practical as there are 27K rows.
I have a range of dates in columns F through AC. I'm trying to use conditional formatting to color the ones that fall between the dates in columns A and B on the same row. IE: Row 2 (1 is headers) A2 and B2 are dates that span one year. F2:AC2 are filled with dates that may or may not fall in that range. Turn the ones that do red (pink red text or what ever). Continue for the next 27K rows.
What I have is working on a 57 item sample Except that it only references the original hard coded selections from the macro recording. I'm struggling with the syntax to make it dynamic.
[code]Sub Conditions()
'
' Conditional format
'
Dim x As Integer
Application.ScreenUpdating = False
NumRows = Range("F2", Range("F2").End(xlDown)).Rows.Count
'Range("F2").Select
'Range(("F2"), Selection.End(xlToRight)).Select
Range("F2").Select
Range(("F2"), Selection.End(xlToRight)).Select
For x = 1 To NumRows
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
Formula1:="=$A$2", Formula2:="=$B$2"
'Formula1:="=ActiveCell.Offset(0,-5)", Formula2:="=ActiveCell.Offset(0,-4)" '<---- offset from active cell
Selection.FormatConditions (Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
Next
Application.ScreenUpdating = True
End Sub [code]
Any help is appreciated.
this worked perfectly.
Sub Conditions2()
Dim numrows As Long
Range("F2").Select
numrows = Range("F2", Range("F2").End(xlDown)).Rows.Count
With Range("F2", Range("F2").End(xlToRight)).Resize(numrows)
With .FormatConditions.Add(Type:=xlCellValue, Operator:=xlBetween, Formula1:="=$A2", Formula2:="=$B2")
.SetFirstPriority
With .Font
.Color = -16383844
.TintAndShade = 0
End With
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
.StopIfTrue = False
End With
End With
End Sub
I can get everything but the original column "U" to copy over (which is a date field). Literally everything else works but this one field, any ideas as to why this one field would not copy over?
Here's what I wrote so far:
Sub CopiesandMovesReferralDatafromOLAB()
Cells.Select
Range("D:D,C:C,E:E,AM:AM,F:F,R:R,AI:AI,AJ:AJ,U:U").Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("B1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("C1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("D1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("E1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("F1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("G1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("H1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("I1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("J1").Select
ActiveCell.FormulaR1C1 = "xxx"
Range("A1:J1").Select
Selection.Font.Bold = True
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10053222
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
Not sure why column U wouldn't copy over, but work with objects instead, and supply the destination range to the Copy method, so that you don't need two instructions, and you're not pasting on whatever random cell is currently active in that destination worksheet - if that cell is A1, then your header row is currently overwriting the first row of data you're pasting over:
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim targetBook As Workbook
Set targetBook = Application.Workbooks.Add
Dim targetSheet As Worksheet
Set targetSheet = targetBook.Worksheets(1)
With sourceSheet.Range("D:D,C:C,E:E,AM:AM,F:F,R:R,AI:AI,AJ:AJ,U:U")
.Copy targetSheet.Range("A2")
End With
As for the rest... use With blocks to work with a given specific Range, instead of successively .Selecting each individual cell and working with ActiveCell like macro-recorder "code":
Dim headings() As Variant
headings = Array("Column1","Column2","Column3", ..., "Column10")
With targetSheet.Range("A1:J1")
.value = headings
With .Font
.Bold = True
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10053222
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.EntireColumn.AutoFit
End With
I don't know how to use variables and what not (I'm not a programmer)
You're writing code, you're programming. Not knowing everything is normal, you're here to learn. As long as you're willing to learn, nothing will stop you. Declare local variables with Dim, assign object references with the Set keyword, specify Option Explicit at the top of every module, and you'll do great!
This macro is supposed to find the value NULL in column "W" and paint the row it found NULL on in a color. It does that fine however if I try to search for a number in the same column(that i know exists there) it doesn't seem to find the value. Any help would be appreciated.
Sub e()
MsgBox "some question?", , "Marvin The Paranoid Android"
Dim fNameAndPath As Variant, wb As Workbook
Dim LastRow As Long, i As Long, sht As Worksheet
Dim myValue As Variant
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Èçáåðåòå ôàéë ñ èìå /Ðåâîëâèíãè/")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
Set sht = wb.Worksheets("Sheet1")
X = wb.Name
Windows(X).Activate
'Macro optimization
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'000000000
ActiveWindow.Zoom = 85
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1:W1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A:E,L:N").EntireColumn.AutoFit
Columns("F:F").ColumnWidth = 6.14
Columns("G:G").ColumnWidth = 6.43
Columns("H:K").ColumnWidth = 5.43
Range("O:R,T:V").ColumnWidth = 4.71
Columns("S:S").ColumnWidth = 14.71
Rows("1:1").RowHeight = 54.54
Range("A1").Select
myValue = InputBox("Give me some input")
LastRow = sht.Cells(sht.Rows.Count, "W").End(xlUp).row
For r = 1 To LastRow
If Cells(r, Columns("W").Column).Value = myValue Then
Rows(r).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next r
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
wb.Close SaveChanges:=True 'or false
'Reverse macro optimization
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Îáðàáîòèõ ôàéë /Ðåâîëâèíãè/...", , "Marvin The Paranoid Android"
End Sub
Autofilter() method of Range object can detect "23" both as number and a text:
With sht
With .Range("W1", .Cells(.Rows.Count, "W").End(xlUp)) '<--| consider column "W" values down to its last non empty row
.AutoFilter field:=1, Criteria1:=myValue '<--| filter column "W" on 'myValue'
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any values match...
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Interior '<--|... consider only filtered values, and apply formatting
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
.ShowAllData '<--| show all rows back...
End With
Try replacing your For loop with the piece of code below.
If you are using Decimal values, or values larger than Integer, make the changes from CInt to your needs:
For r = 1 To LastRow
If sht.Cells(r, "W").Value = CInt(myValue) Then
sht.Rows(r).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next r
Try replacing your loop with this:
Dim tempFind
Set tempFind = ActiveSheet.Columns("W").Find(What:=myValue, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not tempFind Is Nothing Then
With Range(tempFind.Address).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
MsgBox "Not Found!"
End If
When you say:-
if I try to search for a number in the same column(that i know exists there) it doesn't seem to find the value
I assuming you are referring to the below line from your code not returning true and running the code within the If statement.
If Cells(r, Columns("W").Column).Value = myValue Then
In short, if its not finding a match then there is not a match, but it can be hard to see sometimes.
Examples of not matching when you think it should are:-
If the cell contains 12.12121212 but is formatted to show it as 12.12, if you search for 12.12 (as you think that would match) it will not match.
If the cell contains leading or trailing spaces, '12.12 ' (space at the end), if you search for 12.12 (no space at the end) it will not match.
We can see what you are trying to match or what you think should be a match from your question but the above should be the information needed to work the answer out from your content.
Based on the comments, try altering your code with the below, I've added some debugging lines to help understand why its failing: -
'If the value is null it will skip trying to check it, this mean no type mismatch error
If Not IsNull(Cells(r, Columns("W").Column).Value) then
'This prints the value in the cell, the searched value, and if its seen as a match
Debug.Print "'" & Cells(r, Columns("W").Column).Value & "' ,'" & myValue & "', " & (Cells(r, Columns("W").Column).Value = myValue)
'Compares them both as Long data types
If CLng(Cells(r, Columns("W").Column).Value) = CLng(myValue) Then
'Your code
End If
End If
I am trying to create a database which will copy a selected range of data from a main workbook and copy into a separate workbook.
The code causing the issue is below. The 2nd workbook opens based on the value of "W2". A new row should be inserted to the new Wb and formatted then the value of the selected cells pasted.
'Select data to be copied
ActiveCell.Resize(1, 4).Copy
'Open Lessons Learned Db
Location = Range("W2").Value
Set Lessons = Workbooks.Open(Location)
Set LL = Sheets("Lessons Learned")
Windows("Lessons Learned Database.XLSM").Activate
Sheets("Lessons Learned").Activate
'Insert New Row
Range("5:5").Activate
ActiveCell.Offset(1).EntireRow.Insert
'Enter Odd Or Even VALUE
Range("A7").Select
OE = ActiveCell.Value
If OE = 1 Then
Range("A6").Select
ActiveCell.FormulaR1C1 = 0
Else
Range("A6").Select
ActiveCell.FormulaR1C1 = 1
End If
'Hide Permanently Hidden Rows -LINE BELOW GIVES ERROR 1004
Rows("5:5").Select
Selection.EntireRow.Hidden = True
Columns("A").Select
Selection.EntireColumn.Hidden = True
'FORMAT ROW
Range("A6").Select
SC = ActiveCell.Value
If SC = 1 Then
Range("B6:N6").Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Any pointer on where I'm going wrong would be greatly appreciated.
Its advised not to use .Select or .Activate as there are other ways to accomplish this.
Because you were selecting and activating this could have caused the ERROR 1004.
Below i have "cleaned up" your code defining Lessons, LL and Location and included MainWB and defined your ranges.
By defining your Range Excel will always get the .Value from that Range there is then no need to use .Select or .Activate.
As far as tested the below code works:
Sub CopyMainWBtoNewWB()
Dim Lessons As Workbook
Dim LL As Worksheet
Dim MainWB As Workbook
Dim Location As String
Set MainWB = Workbooks("Name Here")
'Open Lessons Learned Db
Location = MainWB.Sheets("Sheet Name").Range("W2").Value
Set Lessons = Workbooks.Open(Location)
Set LL = Lessons.Sheets("Lessons Learned")
'Insert New Row
LL.Rows(5).Offset(1).EntireRow.Insert shift:=xlDown
'Enter Odd Or Even VALUE
If LL.Range("A7").Value = 1 Then
LL.Range("A6").Value = 0
Else
LL.Range("A6").Value = 1
End If
'Hide Permanently Hidden Rows -LINE BELOW GIVES ERROR 1004
LL.Rows(5).Hidden = True
LL.Columns(1).Hidden = True
'FORMAT ROW
If LL.Range("A6").Value = 1 Then
With LL.Range("B6:N6").Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
MainWB.Sheets("Sheet1").Range("A1:A4").Copy
LL.Range("B5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
All you need to do is change the Workbook name of MainWB and the Sheet name its collecting the Valuefor Location.
I suspect your code has some other issues that Code Review may be able to help with but to answer your question:
The Rows("5:5").Select is being passed the wrong argument data type.
Worksheet.Rows() is expecting a number, either Integer or Long data type but you are giving it a string.
Change it to Rows(5) and it should work.
That can all be consolidated to:
ActiveCell.Resize(1, 4).Copy '// not sure what this is for
Set Lessons = Workbooks.Open([w2])
Set LL = Lessons.Sheets("Lessons Learned")
With LL
.Rows(6).EntireRow.Insert
.Range("A6").value = IIf(.Range("A7").value = 1, 0, 1)
.Rows(5).Hidden = True
.Columns("A").Hidden = True
If .Range("A6").value = 1 Then
With .Range("B6:N6").Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
.Range("B5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
You will notice that this code refers directly to each object without activating or selecting it. Coding in this way means that every object is fully qualified and you know exactly which instance you are working with.
This should ensure that the row is correctly hidden without error because you are referring to the Rows collection which is a collection of Ranges with defined properties and methods. Selection can be a sheet, workbook, chart, range or pretty much anything else you can point and click at - so this can cause problems when trying to access properties or methods that belong to a particular object or class.
I'm trying to go go through columns and highlight duplicates within the columns.
I used record macro to get an idea of what I need but I'm not sure how to apply this across many columns. Highlighting all columns won't work because many of the names repeat. I need to find out if a name repeats multiple times within a list.
This is the code I have so far:
Sub findDuplicates()
Application.Goto Reference:="R3C18:R89C18"
Application.Goto Reference:="R3C18:R88C18"
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16751204
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 10284031
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("R21").Select
End Sub
This is code I have that goes through each column within my range from B3:OA3 and sorts by color and alphabet. My thinking is that because this code goes column by column and sorts, I could simply add to it to highlight duplicates within the column it was already sorting. But I'm not sure how'd I'd do that.
Sub sortColorThenAlpha()
'sort by color then by alphabet
Dim rngFirstRow As Range
Dim rng As Range, rngSort As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set rngFirstRow = ws.Range("B3:OA3")
For Each rng In rngFirstRow.Cells
With ws.Sort
Set rngSort = rng.Resize(86, 1) 'to row 88
.SortFields.Clear
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(198, 239, 206)
.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next rng
Application.ScreenUpdating = True
End Sub
This is what I'm looking at. That yellow conditinal formatting is what I'm trying to apply to each column between row 3 and 88.
VBA does not seem necessary as Conditional Formatting with the following rules seems to work:
=A1=VLOOKUP(A1,A2:A$99,1,FALSE) Applies to: =$A$1:$J$99
=A2=VLOOKUP(A2,A$1:A1,1,FALSE) Applies to: =$A$2:$J$99
with references adjusted to suit.
If I understand your question correctly, you want to be able to highlight duplicates in a single column, and you want to be able to automatically apply this formatting to all columns in a given sheet. So if Cleopatra appears once in several columns, she won't be highlighted, but if she appears more than once in a single column, she will.
The following code does just that. I'm finding the last column by looking for a value in row 3.
Sub HighlightDupesOneColumnAtATime()
Dim ws As Worksheet
Dim myColumn As Long
Dim i As Integer
Dim columnCount As Long
Dim lastRow As Long
Dim dupeColor As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
columnCount = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
dupeColor = 9944516
For i = 1 To columnCount
lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
Call HighlightDupesInRange(dupeColor, Cells(1, i).Resize(lastRow, 1))
' it is easy to change the color of the
' highlighted duplicates if you want
dupeColor = dupeColor + 15
Next i
End Sub
Sub HighlightDupesInRange(cellColor As Long, rng As Range)
With rng
.FormatConditions.Delete
.FormatConditions.AddUniqueValues
.FormatConditions(1).DupeUnique = xlDuplicate
.FormatConditions(1).Interior.Color = cellColor
.FormatConditions(1).StopIfTrue = False
End With
End Sub