I'm trying to clear a certain row on the columns A:H and K in my sheet using vba.
In column K there's not only a value, also a checkbox.
I'd like to leave column I en J as they are since there's a formula in those rows.
Now I've tried a lot of different options found shattered on the internet, but can't seem to fix the problem.
My code is as following:
Sub ClearSelected()
Sheets("overview").Unprotect
Sheets("Database").Unprotect
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim counter As Integer
Dim vert As Integer
Dim r As Range
Dim chkbx As CheckBox
Set ws1 = Worksheets("Overview")
Set ws2 = Worksheets("Database")
Set rng = ws1.Range("P2")
vert = rng.Value + 1
counter = 2
'do Loop
Worksheets("Database").Activate
Do While counter < vert
'if "True", remove row
If ws2.Range(ws2.Range("K" & counter)) = True Then
ws2.Range("A" & counter & ":H" & counter).Select
Selection.Clear
ws2.Range("K" & counter).Select
Selection.Clear
'Remove checkbox in selectie
Set r = Selection
For Each chkbx In ActiveSheet.CheckBoxes
If Not Intersect(r, chkbx.TopLeftCell) Is Nothing Then chkbx.Delete
Next chkbx
rng.Value = rng.Value - 1
'remove checkbox
End If
counter = counter + 1
Loop
Sheets("overview").Protect AllowUsingPivotGraphs:=True
Sheets("Database").Protect
End Sub
For some reason it's failing on the range selection/clearing.
I'm getting the errormessage 1004.
Hope you have a good suggestion for me.
I'm not entirely sure if this will work, but have you tried changing the select.clear lines to something like
ws2.Range("K" & counter).ClearContents
This clears the cells without affecting the formatting, which might possibly causing the issue. Sometimes 1004 is also down to a loss of focus on an object, or the size of the range you are trying to operate on.
BTW, you may also not need to worry too much about deleting formulas. You can re-insert them automatically.
Something like:
ws2.Range("K" & counter).FormulaR1C1="=(R+1*C+1)"
'R and C refer to row and column, so equations remain relatively referenced
The easiest way is to start recording a macro, input the desired formula into a cell, and then view the code to find out how to structure the formula in VBA.
Not sure if any of this will help, but here's hoping.
Related
i have found many very similar questions in the forum, but somehow nothing fits what i am looking for.
I have two ranges (a & b) which i'd like to compare and if values do not match, i'd like to copy the entire row to a predefined worksheet. The purpose is to find rows / values that have been changed vs. previous edit.
Dim a, b as range
Dim ws1,ws2,ws3 as worksheet
Dim last_row, last_row2 as integer 'assume last_row =15, last_row2=12
Dim i, j, k as integer
last_row=15
last_row2=12
' the orignal range is not massive, but at 500x 6 not small either
Set a=ws1.range("I5:S"& last_row)
Set b=ws2.range("H2:R"& last_row2)
I have seen different approaches when it comes to addressing each item of the range and don't know which would be quickest / best (loop or for each ).
The main if-statement would look something like this:
'assume i, j are the used as counters running across the range
k = 1
If Not a(i).value=b(j).value then
a(i)EntireRow.copy
ws3.row(k).paste
k = k + 1
end if
The solution cannot be formula based, as I need to have ws3 saved after each comparison.
Any help on this is much appreciated. Thanks!
If you have the ability to leverage Excel Spill Ranges, you can achieve what you want without VBA. Here's a web Excel file that shows all rows in first sheet where column A does not equal column b.
=FILTER(Sheet1!A:ZZ,Sheet1!A:A<>Sheet1!B:B)
If VBA is required, this routine should work. It's not optimal for handling values (doesn't use an array), but it gets it done.
Sub listDifferences()
Dim pullWS As Worksheet, pushWS As Worksheet
Set pullWS = Sheets("Sheet1")
Set pushWS = Sheets("Sheet2")
Dim aCell As Range
For Each aCell In Intersect(pullWS.Range("A:A"), pullWS.UsedRange).Cells
If aCell.Value <> aCell.Offset(0, 1).Value Then
Dim lastRow As Long
lastRow = pushWS.Cells(Rows.Count, 1).End(xlUp).Row
pushWS.Rows(lastRow + 1).Value = aCell.EntireRow.Value
End If
Next aCell
End Sub
This is the small for-loop I ended up using.
Thanks for your input!
For i = 1 To rOutput.Cells.Count
If Not rOutput.Cells(i) = rBackUp.Cells(i) Then
' Debug.Print range1.Cells(i)
' Debug.Print range2.Cells(i)
rOutput.Cells(i).EntireRow.Copy wsChangeLog.Rows(k)
k = k + 1
End If
Next i
I need to fill a range from 10,000 all the way until the end of the column. I have the lRow variable that is finding the last row, and then I have the IF loop that is filling the range just like I need to. The clear contents part is to remove any previous values and fill new ones. The Range("E2").Value = 1 is there to start the series.
The problem is I can't get it to fill the Range("F2:F" & lRow) in a step value of 10,000. The macro just fills out in a step value of 1. Any ideas?
I've tried recording macros but it never works quite right. It needs to be sort of dynamic as the list will grow over time.
This is what it should look like:
Sub MLOS_PriorityTable_StepValues()
Dim ws As Worksheet
Dim lRow As Long
Dim featOrder As Range
Dim Style As Range
Dim dataRange As Range
Dim currentArea As Range
Set ws = ActiveSheet
Set featOrder = ws.Range("A1:ZZ1").Find("FeatureOrder")
Set Style = ws.Range("A1:ZZ1").Find("Style")
Range("E2:E1000").ClearContents
Range("F2:F1000").ClearContents
Range("E2").Value = 1
Range("F2").Value = 10000
lRow = Cells(Rows.Count, Style.Column).End(xlUp).Row
On Error Resume Next
Set dataRange = Range("E2:E" & lRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not dataRange Is Nothing Then
For Each currentArea In dataRange.Areas
With currentArea
With .Offset(-1, 0).Resize(.Rows.Count + 1)
.Cells(1).AutoFill Destination:=.Cells, Type:=xlFillSeries
End With
End With
Next currentArea
End If
On Error Resume Next
Set dataRange = Range("F2:F" & lRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not dataRange Is Nothing Then
For Each currentArea In dataRange.Areas
With currentArea
With .Offset(-1, 0).Resize(.Rows.Count + 1)
.Cells(1).AutoFill Destination:=.Cells, Type:=xlFillSeries
End With
End With
Next currentArea
End If
End Sub
Is the result of F just E*10000? It doesn't matter too much, there's a few ways to solve.
Find your last row number (which you did as lRow)
Iterate for i = 2 to lRow which will loop from the top row with data to the last
Do something in here like Range("F"&i) = Range("E"&i)*10000 assuming that is the relationship or Range("F"&i) = Range("F"&i-1)+10000
next i
it will just iterate cell by cell, make the calculation, and move on.
You may need to make it more robust if you have a script that hops around multiple sheets or workbooks so the range or cell or whatever references you use are correct.
Don't know how fast this would be vs the fill Series function but it doesn't look at face value like it would be too slow.
let me know how you get on!
Rob S
I have a problem...
I have two datasets in the same workbook on different sheets.
The first column in both datasets are identifiers. In Sheet1 I have my dataset, and want to fill it with data from Sheet2 (which is also containing data (rows+Columns) that I do not want to use.
I have a VBA that is working, BUT, it stops before it is done.
E.g. I have 1598 Rows in Sheet2, but it stops working already after 567 rows..
Sub Test()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Sheet2")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 2
For Each c In Source.Range("A2", Source.Range("A" & Source.Cells(Source.Rows.Count, "A").End(xlUp).Row))
If c = Target.Cells(j, 1).Value Then
Source.Range("D" & c.Row & ":AS" & c.Row).Copy Target.Cells(j, 26)
j = j + 1
End If
Next c
MsgBox "Done"
End Sub
Can someone help me and see if there is something obviously wrong with the code? I have tried it on smaller datasets, and then it works perfect.
If more information needed or you have some other tips, please ask/tell :D
Thanks!
VBA Solution
Try the following, it usese the WorksheetFunction.Match method to properly match the values of column A no matter which order they are.
It loops through all rows in Target, and tries to find a matching row in Source. If a match was found it copies it into the Target.
Option Explicit
Public Sub Test()
Dim Source As Worksheet
Set Source = ThisWorkbook.Worksheets("Sheet2")
Dim Target As Worksheet
Set Target = ThisWorkbook.Worksheets("Sheet1")
Dim LastRowTarget As Long
LastRowTarget = Target.Cells(Target.Rows.Count, "A").End(xlUp).Row
Dim tRow As Long
For tRow = 2 To LastRowTarget
Dim sRowMatch As Double
sRowMatch = 0 'reset match row
On Error Resume Next 'ignore if next line throws error
sRowMatch = Application.WorksheetFunction.Match(Target.Cells(tRow, 1).Value, Source.Columns("A"), 0)
On Error GoTo 0 're-enable error reporting
If sRowMatch <> 0 Then 'if matching does not find anything it will be 0 so <>0 means something was found to copy
Source.Range("D" & sRowMatch & ":AS" & sRowMatch).Copy Target.Cells(tRow, 26)
End If
Next tRow
MsgBox "Done"
End Sub
Formula Solution
Note that there is no need for VBA and this could actually also solved with formulas only. Either the VLOOKUP formula or a combination of INDEX and MATCH formula.
So in Sheet1 cell Z2 write =INDEX(Sheet2!D:D,MATCH($A2,Sheet2!$A:$A, 0)) and pull it down and right.
I cannot figure out why this happens (it only happens intermittently, but always with the same function)...
I am inserting a few copied rows wherever the user happens to be, and checking if a page break is necessary between them.
I managed to recover Excel after it crashed one time, and found it stalling on a line with an ActiveCell reference. I apostrophe'd the line out, and the code continued successfully line by line to the next ActiveCell reference.
I reopened the template file with the code in it, and it worked just fine.
I know it's bad practice to use ActiveCell, but I don't know how to get around it in this case - I need to add the rows right where the user is.
Should I do something like this?
Dim R As Range
Set R = ActiveCell.Address
Will that keep the original ActiveCell address or will it dynamically update as the code runs and the ActiveCell changes?
Your help is much appreciated!
[Edit]: Code (please excuse untidiness it's in development):
Sub InsertArea()
'Dimension variables
Dim SR
Dim Rng2 As Range
Dim i, j, PB1 As Integer
Dim Crit() As String
Dim w As Worksheet
i = 2
j = 0
PB1 = 0
Set Rng = Nothing
'NEW PAGE
'Check for page height breach
'Assign PB1 to selection row
PB1 = Selection.Row
'Reset i to 1
i = 1
'Loop how many extra blank rows you want below the bottom spec on a page
Do Until i = 17
'If there's a page break above row i
If Rows(PB1).Offset(i, 0).EntireRow.PageBreak <> xlPageBreakNone Then
'Copy blank row
Range("A1000:A1006").EntireRow.Copy
Selection.EntireRow.Insert Shift:=xlDown
'Insert page break just above the new area
Rows(PB1).Offset(4, 0).PageBreak = xlPageBreakManual
Selection.Offset(7, 0).Select
i = 17
Else
'Increment i to prevent infinite loop
i = i + 1
End If
Loop
'INSERT NEW AREA
'Copy blank new area
ActiveWorkbook.Names("Temp_NewArea").RefersToRange.EntireRow.Copy
'Paste (insert) that line by shifting cell up, so target cell remains in the new blank row
BUGS HERE
ActiveCell.EntireRow.Insert Shift:=xlUp
'ASSIGN NEW AREA WITH A NEW NAME
SR = ActiveWorkbook.Names("Spec1").RefersToRange.Address
'Amend selection to Quoted Specifications
ActiveCell.Offset(2, 7).Resize(4, 1).Select
'ADD THE NEW AREA TO SPECIFIED_RANGES
'Add that specified range to string SR, comma separated
SR = SR & ":" & Range("Quote_End").Offset(-3, 1).Address
'Create/Overwrite (by default) Specified_Areas range using string SR
ActiveWorkbook.Names.Add "Specified_Ranges", "=" & SR
ActiveCell.Offset(4, -7).Activate
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
Instead of using ActiveCell throughout the code, you should immediately assign it to a variable and utilize that variable instead.
Sub InsertArea()
'Dimension variables
Dim SR
Dim Rng2 As Range
Dim i, j, PB1 As Integer
Dim Crit() As String
Dim w As Worksheet
'Then declare your cell in question
Dim myCell As Range
Set myCell = ActiveCell
This will prevent cases where the ActiveCell inadvertently changes while the code is running.
Also, within your declarations
Dim i, j, PB1 As Integer
i & j are declared as type Variant, while PB1 is declared as type Integer. While it is perfectly acceptable to declare more than one variable on a single line, these declarations must be done explicitly, such as:
Dim i As Integer, j As Integer, PB1 As Integer
- OR -
Dim i%, j%, PB1%
The % is the VB symbol for Integer, and may be used in declaring variables.
Posted as answer per OP request
I have an excel sheet with around 200 work sheets each containing a list of products sold to a company.
I need to add
A total at the bottom of row D-G where the bottom can be a different value. I.E. E4
below the total a formula based on the total. I.E. if E4 (being the bottom of the above row) is below $999 the display text "samples", if between 1000-3000 then multiply E4 by 2%, 3001-7500 x 5% etc.
I need to be able to add it to the entire workbook easily using vba. Since I must do this to numerous ss it would literally save me 15-20 hours a month.
Edit:
So I have something that seems to be the right path.
Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))
'Delete any sheet called "UniqueList"
'Turn off run time errors & delete alert
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"
'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A3", .Range("A65536").End(x2Up))
End With
On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add().Name = strText
'Copy the visible filtered range _
(default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With wSheetStart
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
Dim colm As Long, StartRow As Long
Dim EndCell As Range
Dim ws As Worksheet
StartRow = 3
For Each ws In Worksheets
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
If EndCell.Row > StartRow Then EndCell.Resize(, 4).Formula = "=SUM(R" & StartRow & "C:R[-1]C)"
Set EndCell = ws.Cells(Rows.Count, "D").End(xlUp)
If EndCell.Row >= 1000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.05))
Range(J3) = "5% Discount"
ElseIf EndCell.Row >= 3000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.1))
Range(J3) = "10% Discount"
End If
Next ws
End Sub'
Just need to figure out how to display the results and text to the right cells (J2 in this case)
I will supply the logic and all the references you need to put this one together; and will let you try to put it together on your own :). Come back for more help if needed.
You need to loop through all the worksheets in your workbook (Microsoft Tutorial)
You need to find the last row for the given columns (Online tutorial)
You need to use an IF statement to choose which formula to use (MSDN reference)
UPDATE
What's wrong with your code is this line :
Range(J2) = Formula = ((EndCell.Row) * (0.1))
What you're telling the computer is :
Multiply EndCell.Row by 0.1 (which has the number of the row below and to the right of the last cell in column C)
Compare Formula with the result previously obtained
Store the result of that logical expression at the range stored in variable J2
First of all, what you want is to put the result of the equation, and want to change J2 to "J2" so it gets the cell J2, instead of the what's contained in J2 (which has nothing at that point)
Also, you seem to say that you're not getting the right cells, maybe it is caused by this :
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
In that line, you're finding the last cell of column C, but then you select the cell below, and to the right of it.
There are so many things wrong with your code it's hard to say what's not working properly.