I have an issue where, once I use a userform within the file, the public sub that is inserting columns on my sheets stops working. I run into this issue once I use this specific userform. I can add certain information and have the public sub add in the new columns, however, once I use the one userform, it no longer functions.
A scenario that works with no problems:
- Import xml
- Add columns based on XML
- Add in new member
- Add column with new member
A scenario that does not work:
- Import XML
- Add columns based on XML
- Use macro/userform to make adjustment to any member
- Add in new member
- New column will not be added in for new member
I can continue to add in new members and update the amount of columns that are inserted, however, once I hit the button to call the adjustment userform, the functionality to add in new columns (or delete columns) goes away.
This is in the sheet module for the worksheet change that controls the amount of columns to be added/deleted
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim KeyCells As Range, colNum As Long
Dim ws As Worksheet
SOMESHEETS = "*C-Proposal-19*MemberInfo-19*Schedule J-19*NOL-19*NOL-P-19*NOL-PA-19*Schedule R-19*Schedule A-3-19*Schedule A-19*Schedule H-19*"
Set KeyCells = Range("B30")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
If IsNumeric(KeyCells.Value) Then
colNum = KeyCells.Value
If colNum > 0 Then
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
If CBool(InStr(LCase(SOMESHEETS), LCase("*" & ws.Name & "*"))) Then
InsertColumnsOnSheet argSheet:=ws, argColNum:=colNum
End If
End If
Next ws
End If
End If
End If
SOMESHEETS = "*MemberInfo-20*C-Proposal-20*Schedule J-20*NOL-20*Schedule R-20*NOL-P-20*SchA-3-20*Schedule H-20*NOL-PA-20*Schedule A-20*Schedule A-5-20*"
Set KeyCells = Range("B36")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
If IsNumeric(KeyCells.Value) Then
colNum = KeyCells.Value
If colNum > 0 Then
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
If CBool(InStr(LCase(SOMESHEETS), LCase("*" & ws.Name & "*"))) Then
InsertColumnsOnSheet argSheet:=ws, argColNum:=colNum
End If
End If
Next ws
End If
End If
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ErrorHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is the code that controls the columns that are copied and where they are inserted for each page
Option Explicit
Public Sub InsertColumnsOnSheet(ByVal argSheet As Worksheet, ByVal argColNum As Long)
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim Rng As Range, c As Range
Dim TotalCol As Long, LeftFixedCol As Long, i As Long
Dim j As Integer, k As Integer
With argSheet
Set Rng = .Range("3:3")
Set c = Rng.Find("END")
If Not c Is Nothing Then
TotalCol = c.Column
LeftFixedCol = Application.WorksheetFunction.Match("Member1", argSheet.Range("3:3"), 0) - 1
j = .Range("B4").End(xlToRight).Column
k = j - LeftFixedCol
If argSheet.Visible = xlSheetVisible Then
If TotalCol < LeftFixedCol + argColNum + 1 Then
.Columns(j).Copy
.Columns(j + 1).Resize(, argColNum - k).Insert CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
End If
If TotalCol > LeftFixedCol + argColNum + 1 Then
For i = TotalCol - 1 To LeftFixedCol + argColNum + 1 Step -1
.Columns(i).Delete
Next i
End If
End If
End If
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ErrorHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is the code for the userform that seems to be causing the issue
Option Explicit
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim N As Long
Dim i As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Dim Rng5 As Range
Set ws = ActiveSheet
Set Rng1 = ws.Range("6:6").Find(Me.TextBox2.Value)
Set Rng2 = ws.Range("6:6").Find(Me.TextBox6.Value)
Set Rng3 = ws.Range("6:6").Find(Me.TextBox5.Value)
Set Rng4 = ws.Range("6:6").Find(Me.TextBox4.Value)
Set Rng5 = ws.Range("6:6").Find(Me.TextBox7.Value)
N = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox2, ws.Range("6:6"), TextBox2) = 0 And ComboBox1 <> 0 Then
MsgBox "Sorry, " & TextBox2 & " not found!"
Else
If TextBox3.Value = "" And ComboBox1.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox6, ws.Range("6:6"), TextBox6) = 0 And ComboBox2 <> 0 Then
MsgBox "Sorry, " & TextBox6 & " not found!"
Else
If TextBox8.Value = "" And ComboBox2.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox5, ws.Range("6:6"), TextBox5) = 0 And ComboBox3 <> 0 Then
MsgBox "Sorry, " & TextBox5 & " not found!"
Else
If TextBox9.Value = "" And ComboBox3.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox4, ws.Range("6:6"), TextBox4) = 0 And ComboBox4 <> 0 Then
MsgBox "Sorry, " & TextBox4 & " not found!"
Else
If TextBox10.Value = "" And ComboBox4.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox7, ws.Range("6:6"), TextBox7) = 0 And ComboBox5 <> 0 Then
MsgBox "Sorry, " & TextBox7 & " not found!"
Else
If TextBox11.Value = "" And ComboBox5.Value <> "" Then
MsgBox "There is no data to add", 48
Else
For i = 5 To N
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox1.Value Then
ActiveSheet.Cells(i, Rng1.Column).Value = frmAddAdj.TextBox3.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox2.Value Then
ActiveSheet.Cells(i, Rng2.Column).Value = frmAddAdj.TextBox8.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox3.Value Then
ActiveSheet.Cells(i, Rng3.Column).Value = frmAddAdj.TextBox9.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox4.Value Then
ActiveSheet.Cells(i, Rng4.Column).Value = frmAddAdj.TextBox10.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox5.Value Then
ActiveSheet.Cells(i, Rng5.Column).Value = frmAddAdj.TextBox11.Text
End If
Next i
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
ErrorHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub CommandButton2_Click()
Unload frmAddAdj
End Sub
Private Sub CommandButton3_Click()
Dim ctl As MSForms.Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox", "ComboBox"
ctl.Text = ""
Case "CheckBox", "OptionButton", "ToggleButton"
ctl.Value = False
End Select
Next ctl
End Sub
Private Sub UserForm_Initialize()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim iRow As Integer, iMax As Integer
iRow = Cells.Find(What:="New Jersey Audit Adjustment", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
iMax = Cells.Find(What:="New Jersey Audit Adjustment", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False).Row
If ActiveSheet.Range("B" & iRow & ":B" & iMax).Cells.Count = 1 Then
Me.ComboBox1.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox2.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox3.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox4.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox5.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Else
Me.ComboBox1.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox2.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox3.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox4.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox5.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
End If
ErrorHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
I can't figure out why adding in the new columns stops after I use the add adjustment macro. This is the last bit of code above.
I tried adding in the errorhandler but that didn't change the end result. I also add a debugger to try and find out if there was an error, and it would pop up saying there was an error with no information being provided. The line and description were blank, so that was no help.
Related
I have some code that colours in a row of information and then stores the date and the user that coloured in said row of information on a log.
That is all well and good but I would like to somehow figure out how to reverse said process. Currently if you use the code again on the same selection the colour changes back to 'no fill' but unfortunately I'm not sure how to remove that same information that was sent to the log initially. Any ideas?
Sub CompleteLine()
Dim RCount As Integer
RCount = Selection.Columns.Count
If Selection.Interior.Color = 5296274 Then
Selection.Interior.ColorIndex = 0
Else
If RCount = 16384 And Selection.Interior.Color <> 5296274 Then
Selection.Interior.Color = 5296274
With Sheets("Log")
.Cells(1, 1).End(xlDown).Offset(1) = Format(Date, "dd/mm/yyyy")
.Cells(1, 2).End(xlDown).Offset(1) = Environ("Username")
End With
End If
End If
End Sub
Try this out. There is room for improvement, but it should work. It should at least get you started
Sub CompleteLine()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim RCount As Integer
Dim lastrow As Long
Dim checkC As Boolean
RCount = Selection.Columns.Count
With Selection
If .Interior.Color = 5296274 Then
.Interior.ColorIndex = 0
checkC = False
Else
If RCount = 16384 And .Interior.Color <> 5296274 Then .Interior.Color = 5296274
checkC = True
End If
End With
With Sheets("Log")
lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
If checkC = True Then
.Range("A" & lastrow & ":A" & lastrow) = Format(Date, "dd/mm/yyyy")
.Range("B" & lastrow & ":B" & lastrow) = Environ("Username")
Else
If checkC = False Then .Range("A" & lastrow & ":B" & lastrow - 1).ClearContents
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I have the code below which, in a simple request form, gives requestor an option to add a line for the same user.
When "Yes" is selected from a drop-down menu, a new line populates with the same Name and Alias used in the previous row, while other rows below it would move down by one row accordingly.
The code to ADD a new line (works fine) is as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" & Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
End With
End Sub
I modified the above code as follows so it does remove a row below if the "No" option is selected. And it is working properly:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" & Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End With
End Sub
However, I want to make sure that a below row is deleted after selecting "No" only in cases where the below row that is to be deleted contains same data as the row above. As it is now, it removes the below line in any case, i.e. even if the requestor previously didn't click "Yes", and that's not a desired outcome.
I've been trying to modify the "No" condition as follows but still struggling:
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
If Range("A" & Target.Row & ":C" & Target.Row).Value = Range("A" & Target.Row + 1 & ":C" & Target.Row + 1).Value Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End If
Could you please help?
FOLLOW-UP:
The code I'm having now is this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" &
Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
AllOk = True
For Each xCel In UpperRow.Cells
If AllOk And (xCel.Value <> xCel.Offset(1, 0).Value) Then
AllOk = False
End If
Next xCel
If AllOk Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End If
End With
End Sub
I keep getting '424' error "Object required" and the debug highlights this: For Each xCel In UpperRow.Cells
Could you please help? Apologies I'm a beginner in this...
As an indicative answer
AllOk = True
for each xCel in UpperRow.Cells
if AllOk and (xCel.Value <> xCel.Offset(1,0).Value) then
AllOk = False
End If
Next xCel
IF AllOk then
' Delete the Row
End If
You'll need to fill in some details and maybe some error checking - not a full answer
I have a VBA code that works perfectly. I copied the file to a new computer and now it s returning errors when running.
Same library references are added and I am using same Excel version 2016.
Option Explicit
Public Const firstTickerRow As Integer = 13
Sub DownloadData()
Dim frequency As String
Dim lastRow As Integer
Dim lastErrorRow As Integer
Dim lastSuccessRow As Integer
Dim stockTicker As String
Dim numStockErrors As Integer
Dim numStockSuccess As Integer
Dim startDate As String
Dim endDate As String
Dim ticker As Integer
Dim crumb As String
Dim cookie As String
Dim validCookieCrumb As Boolean
Dim sortOrderComboBox As Shape
Dim ws As Worksheet
Sheets("Analysis").Cells.ClearContents
Sheets("Filter Stocks").Cells.ClearContents
numStockErrors = 0
numStockSuccess = 0
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lastErrorRow = ActiveSheet.Cells(Rows.Count, "J").End(xlUp).Row
lastSuccessRow = ActiveSheet.Cells(Rows.Count, "L").End(xlUp).Row
ClearErrorList lastErrorRow
ClearSuccessList lastSuccessRow
lastRow = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
frequency = Worksheets("Parameters").Range("b7")
'Convert user-specified calendar dates to Unix time
'***************************************************
startDate = (Sheets("Parameters").Range("startDate") - DateValue("January 1, 1970")) * 86400
endDate = (Sheets("Parameters").Range("endDate") - DateValue("January 1, 1970")) * 86400
'***************************************************
'Set date retrieval frequency
'***************************************************
If Worksheets("Parameters").Range("frequency") = "d" Then
frequency = "1d"
ElseIf Worksheets("Parameters").Range("frequency") = "w" Then
frequency = "1wk"
ElseIf Worksheets("Parameters").Range("frequency") = "m" Then
frequency = "1mo"
End If
'***************************************************
'Delete all sheets apart from Parameters sheet
'***************************************************
For Each ws In Worksheets
If ws.Name <> "Parameters" And ws.Name <> "Stocks" And ws.Name <> "Analysis" And ws.Name <> "Filter Stocks" Then ws.Delete
Next
'***************************************************
'Get cookie and crumb
'***************************************************
Call getCookieCrumb(crumb, cookie, validCookieCrumb)
If validCookieCrumb = False Then
GoTo ErrorHandler:
End If
'***************************************************
'Loop through all tickers
For ticker = firstTickerRow To lastRow
stockTicker = Worksheets("Parameters").Range("$a$" & ticker)
If stockTicker = "" Then
GoTo NextIteration
End If
'Create a sheet for each ticker
'***************************************************
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = stockTicker
Cells(1, 1) = "Stock Quotes for " & stockTicker
'***************************************************
'Get financial data from Yahoo and write into each sheet
'getCookieCrumb() must be run before running getYahooFinanceData()
'***************************************************
Call getYahooFinanceData(stockTicker, startDate, endDate, frequency, cookie, crumb)
'***************************************************
'Populate success or fail lists
'***************************************************
lastRow = Sheets(stockTicker).UsedRange.Row - 2 + Sheets(stockTicker).UsedRange.Rows.Count
If lastRow < 3 Then
Sheets(stockTicker).Delete
numStockErrors = numStockErrors + 1
ErrorList stockTicker, numStockErrors
GoTo NextIteration
Else
numStockSuccess = numStockSuccess + 1
If Left(stockTicker, 1) = "^" Then
SuccessList Replace(stockTicker, "^", ""), numStockSuccess
Else
SuccessList stockTicker, numStockSuccess
End If
End If
'***************************************************
'Set the preferred date format
'***************************************************
Range("a3:a" & lastRow).NumberFormat = "yyyy-mm-dd;#"
'***************************************************
'Sort by oldest date first or newest date first
'***************************************************
Set sortOrderComboBox = Sheets("Parameters").Shapes("SortOrderDropDown")
With sortOrderComboBox.ControlFormat
If .List(.Value) = "Oldest First" Then
Call SortByDate(stockTicker, "oldest")
ElseIf .List(.Value) = "Newest First" Then
Call SortByDate(stockTicker, "newest")
End If
End With
'***************************************************
'Clean up sheet names
'***************************************************
'Remove initial ^ in ticker names from Sheets
If Left(stockTicker, 1) = "^" Then
ActiveSheet.Name = Replace(stockTicker, "^", "")
Else
ActiveSheet.Name = stockTicker
End If
'Remove hyphens in ticker names from Sheet names, otherwise error in collation
If InStr(stockTicker, "-") > 0 Then
ActiveSheet.Name = Replace(stockTicker, "-", "")
End If
'***************************************************
NextIteration:
Next ticker
'Process export and collation
'***************************************************
If Sheets("Parameters").Shapes("WriteToCSVCheckBox").ControlFormat.Value = xlOn Then
On Error GoTo ErrorHandler:
Call CopyToCSV
End If
If Sheets("Parameters").Shapes("CollateDataCheckBox").ControlFormat.Value = xlOn Then
On Error GoTo ErrorHandler:
Call CollateData
End If
'***************************************************
ErrorHandler:
Worksheets("Parameters").Select
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Call Dynamic
End Sub
Sub SortByDate(ticker As String, order As String)
Dim firstRow As Integer
Dim lastRow As Integer
Dim sortType As Variant
lastRow = Sheets(ticker).UsedRange.Rows.Count
firstRow = 2
If order = "oldest" Then
sortType = xlAscending
Else
sortType = xlDescending
End If
Worksheets(ticker).Sort.SortFields.Clear
Worksheets(ticker).Sort.SortFields.Add Key:=Sheets(ticker).Range("A" & firstRow & ":A" & lastRow), _
SortOn:=xlSortOnValues, order:=sortType, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(ticker).Sort
.SetRange Range("A" & firstRow & ":G" & lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
The error is produced at the line Worksheets(ticker).Sort.SortFields.Clear:
Error 9: Subscript out of range
I am not sure why this is occurring now.
I have a workbook like so:
Column A U
Supplier A 10
Supplier B 1
Supplier C 5
Supplier D 9
I am trying to highlight the entire row in red, only for the top 10 numbers in column B.
Here is my conditional formatting rule:
For some reaason the rows are only changing font colour, and the row is not highlighted. I reckon this has something to do with me turning off calculations?
My vba code includes:
Option Explicit
Sub code()
MsgBox "This will take upto 3 minutes."
Application.ScreenUpdating = False
Dim WB As Workbook
Dim i As Long
Dim j As Long
Dim Lastrow As Long
On Error Resume Next
Set WB = Workbooks("L.O. Lines Delivery Tracker.xlsm")
On Error GoTo 0
If WB Is Nothing Then 'open workbook if not open
Set WB = Workbooks.Open("G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\L.O. Lines Delivery Tracker.xlsm")
End If
' ======= Edit #2 , also for DEBUG ======
With WB.Worksheets(1)
Lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
j = 2
For i = 7 To Lastrow
' === For DEBUG ONLY ===
Debug.Print CInt(ThisWorkbook.Worksheets(1).Range("F9").value)
Debug.Print Month(.Range("G" & i).value)
Debug.Print CInt(ThisWorkbook.Worksheets(1).Range("F10").value)
Debug.Print Year(.Range("G" & i).value)
Debug.Print ThisWorkbook.Worksheets(1).Range("B6").value
Debug.Print .Range("M" & i).value
If CInt(ThisWorkbook.Worksheets(1).Range("F9").value) = Month(.Range("G" & i).value) Then ' check if Month equals the value in "A1"
If CInt(ThisWorkbook.Worksheets(1).Range("F10").value) = Year(.Range("G" & i).value) Then ' check if Year equals the value in "A2"
If ThisWorkbook.Worksheets(1).Range("B6").value = .Range("M" & i).value Then
ThisWorkbook.Worksheets(2).Range("A" & j).value = .Range("G" & i).value
ThisWorkbook.Worksheets(2).Range("B" & j).Formula = "=MONTH(B" & j & ")"
ThisWorkbook.Worksheets(2).Range("C" & j).value = .Range("L" & i).value
ThisWorkbook.Worksheets(2).Range("D" & j).value = .Range("D" & i).value
ThisWorkbook.Worksheets(2).Range("E" & j).value = .Range("E" & i).value
ThisWorkbook.Worksheets(2).Range("F" & j).value = .Range("F" & i).value
ThisWorkbook.Worksheets(2).Range("g" & j).value = .Range("p" & i).value
ThisWorkbook.Worksheets(2).Range("H" & j).value = .Range("H" & i).value
ThisWorkbook.Worksheets(2).Range("I" & j).value = .Range("I" & i).value
ThisWorkbook.Worksheets(2).Range("J" & j).value = .Range("J" & i).value
ThisWorkbook.Worksheets(2).Range("k" & j).value = .Range("Q" & i).value
ThisWorkbook.Worksheets(2).Range("L" & j).value = .Range("m" & i).value
j = j + 1
End If
End If
End If
Next i
End With
Worksheets(1).UsedRange.Columns("B:AA").Calculate
On Error GoTo Message
With ThisWorkbook.Worksheets(1) '<--| change "mysheet" to your actual sheet name
Intersect(.Range(Rows(14), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("G:G")).WrapText = True
Intersect(.Range(Rows(14), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("G:G")).EntireRow.AutoFit
End With
'End
Application.ScreenUpdating = True
Exit Sub
Message:
On Error Resume Next
Exit Sub
End Sub
And
Private Sub Worksheet_Change(ByVal Target As Range)
Application.Calculation = xlManual
Application.CalculateBeforeSave = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.Calculation = xlManual
Application.CalculateBeforeSave = False
End Sub
And
Private Sub Workbook_Open()
Application.Calculation = xlManual
Application.CalculateBeforeSave = False
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.Calculation = xlManual
Application.CalculateBeforeSave = False
End Sub
Please can someone show me where i am going wrong?
Please try:
Sub CF()
Cells.Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND($B1>=LARGE($B:$B,10),ROW()<>1)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.Interior.Color = 255
.StopIfTrue = False
End With
End Sub
I am working on writing a macro that deletes all rows that are less than .75 from a value I found using a formula. In another thread, on here, I found a loop that works, but this takes a lot of time to run... so I am trying to find a way without a loop. So far, I have the code as seen below, but i get a "run-time error 1004, method 'range of object worksheet' failed" on the line
ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Select
Anybody have any ideas on a correction? All help is appreciated
Private Sub CommandButton6_Click()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim i&, lr&, rowsToDelete$, lookFor$, lookFor2$
'*!!!* set the condition for row deletion
lookFor = "#VALUE!"
lookFor2 = "0.75"
Set ws = ThisWorkbook.Sheets("Entry")
lr = ws.Range("H" & Rows.Count).End(xlUp).row
ReDim arr(0)
For i = 1 To lr
If StrComp(CStr(ws.Range("H" & i).Text), lookFor, vbTextCompare) = 0 Or _
CDbl(ws.Range("H" & i).Value) < CDbl(lookFor2) Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr) - 1) = i
End If
Next i
If UBound(arr) > 0 Then
ReDim Preserve arr(UBound(arr) - 1)
For i = LBound(arr) To UBound(arr)
rowsToDelete = rowsToDelete & arr(i) & ":" & arr(i) & ","
Next i
ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Select
Selection.Delete Shift:=xlUp
lr = ws.Range("A" & Rows.Count).End(xlUp).row
ws.Range(lr & ":" & lr).Select
Else
Application.ScreenUpdating = True
MsgBox "No more rows contain: " & lookFor & "or" & lookFor2 & ", therefore exiting"
Exit Sub
End If
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Here is one way:
Sub Macro1()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim r As Range
Set r = Sheet1.UsedRange
r.AutoFilter Field:=8, Criteria1:="<.75", _
Operator:=xlAnd
r.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
r.AutoFilter
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
This assumes that column H (or 8 in the code above) holds the value you want to filter for. You'll have to adjust to fit your sheet.