I was trying to delete my unwanted columns in the ACTIVE sheet using the below code :
Sub DeleteUnwantedColumns()
Dim LastUsedCell As Integer
Dim deleteRange As Range
LastUsedCell = ActiveSheet.UsedRange.Columns.count
Set deleteRange = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, LastUsedCell))
arr = Array("FY17", "FY18", "FY19", "FY20", "FY21")
For Each cell In ActiveWorkbook.Worksheets("Sheet1").Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, LastUsedCell))
If IsError(Application.Match(cell.Value, arr, 0)) Then
ActiveSheet.Cells.EntireColumn.Delete
End If
Next
End Sub
with this code sheets are deleting which is not mentioned in the Array, but if i am deleting the column 2 then column 3 will be the column 2, so in that case the code is skipping the column 2 if the value is something else in the column 2.
is there any way to work this code from last usedcolumn to first column.
i tried with step-1 , but it showing an error in the code itself.
any help is appreciated.
Thank you in Advance
Use a for loop and go backwards from usedRange.Columns.Count with Step -1. You never used DeleteRange so I removed it.
Sub DeleteUnwantedColumns()
Dim arr As Variant
Dim c As Integer
arr = Array("FY17", "FY18", "FY19", "FY20", "FY21")
For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If IsError(Application.Match(ActiveSheet.Cells(1, c), arr, 0)) Then
ActiveSheet.Columns(c).Delete
End If
Next
End Sub
Related
So here is the task I am required to do.
I have a worksheet in which the user can specify a Column name and an element under the column, once chosen, the macro will find and delete every element with said name.
My issue comes from the final part of the macro, the delete. My loop doesn't delete all the rows, it will only find one instance of the element and delete it, then go to the next element and delete it, leaving every other element with the same name intact.
Here is the function within the macro, I apologize in advance for the poor code quality as I am not well versed in vba.
Function LineDelete() As Variant
Dim NbLignes As Integer
Dim ctr As Integer
Dim ctr2 As Integer
Dim Table As Variant
Worksheets("parametrage_suppr_ligne").Activate
ctr = 1
ctr2 = 1
NbLignes = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row - 4
ReDim Table(1 To NbLignes, 2)
While ctr <= NbLignes
Table(ctr, 1) = Cells(ctr + 4, 1).Value
Table(ctr2, 2) = Cells(ctr2 + 4, 2).Value
ctr = ctr + 1
ctr2 = ctr2 + 1
Wend
Call FileOpen
Call delInvalidChars
Call OrderRows
Dim newCtr As Integer
Dim rng As Range
Dim rngHeaders As Range
Dim newString As Variant
Dim i As Integer
NbLignes = 0
NbLignes = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
Set rngHeaders = Range("1:1")
newCtr = 1
For i = NbLignes To FirstRow Step -1
Set rng = rngHeaders.Find(Table(newCtr, 1))
If Table(newCtr, 1) = rng Then
MsgBox "All is gud!!"
newString = Cells.Find(Table(newCtr, 2))
If Table(newCtr, 2) = newString Then
MsgBox newString
Range(Cells.Find(Table(newCtr, 2)).Address).EntireRow.Delete
newCtr= newCtr + 1
End If
End If
newCtr = newCtr + 1
Next i
End Function
So now to explain a bit what I've done here.
At first I store the options in a 2 dimentional table with a simple loop, in this table I store the name of the column a well as the name of the element under the column that has to be deleted.
After that I call the functions which open a txt file which is then transformed into an excel file, it is in this new excel file that the deletes have to be done.
I then reset the NbLignes variable as well as call new variables.
Here is where the issues begin, I thought that by iterating on the number of lines the new excel file has; the program was going to look for all of the instances of the word in the column and was going to delete them, but so far it will only do it 3 times.
I am totally lost as to what modify to be able to fix this.
Here is what the config table looks like, this is what the user can modify to specify what to delete, it is also what I store inside of the 2d Table:
User can add as many columns and names as needed
EDIT: What the code does now after updating is that it deletes all the elements that have the same name as the first one in the image (fun_h_opcomp), the expected outcome would be that as soon as all those elements are deleted, the program should then pass on to the next one (fun_b_pterm) and so on.
Of course the i was just an Example for that counter and you must use your newCtr counter here, and FirstRow must be set to a value.
Const FirstRow As Long = 1
Dim newCtr As Long 'always use Long for row counting
For newCtr = NbLignes To FirstRow Step -1
Set rng = rngHeaders.Find(Table(newCtr, 1))
If Table(newCtr, 1) = rng Then
MsgBox "All is gud!!"
newString = Cells.Find(Table(newCtr, 2))
If Table(newCtr, 2) = newString Then
MsgBox newString
Range(Cells.Find(Table(newCtr, 2)).Address).EntireRow.Delete
End If
End If
Next newCtr
There is no need to increment/decrement newCtr anymore because this is automatically done by the Next statement.
I need to check each cell in row 7 starting from C7 (C7, D7, E7, etc) and find a cell with a string value that contains a certain date (for example, "9/30/2017" in string "6/30/2017 to 9/30/2017") and delete ALL columns from column C to whatever column that the cell is in. How would I do this with VBA code? I am new to VBA and have tried everything that I could find. Thankful for any suggestions
My code:
Sub DeleteUnnecessaryColumns(specifiedWorksheet)
Dim lastCol As Long
lastCol = Cells.Find(What:="*", After:=[C1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = 1 To lastCol
If InStr(Cells(7, 0), specifiedDate, vbTextCompare) = 0 Then
Columns(i).Delete
End If
Next i
End Sub
A few changes:
Use a With block to explicitly target the specified worksheet
Add a . before the Cells collection to explicitly link to the specified worksheet (through the With block)
Start the loop with the correct column index for Column C = 3 (For i = 3 ...)
You missed the first argument to the InStr function: starting character (1 was assumed) MSDN
The second argument for InStr wasn't set to the i variable. This will now cycle through the values in each column
The loop would not stop once it found the search text. So I added an Else clause that exits the For loop once specifiedDate is found, preventing the script from deleting columns to the right of the target column.
specifiedDate was never passed to the Sub or declared so I added it as a parameter. You can also declare and set it within this procedure. If it's declared as a public variable, then delete the parameter.
The .Find method is only available to a range object, so I used a method available to cells instead
After a column is deleted, the indices for the remaining columns are reduced by one so the same must be done to the variables controlling the loop
It should now properly delete a column if the search text is not found in row 7 and will stop executing once the first match is found, leaving the remaining columns intact.
Sub DeleteUnnecessaryColumns(specifiedWorksheet, specifiedDate)
Dim lastCol As Long
With specifiedWorksheet
lastCol = .Cells(7, .Columns.Count).End(xlToLeft).Column
For i = 3 To lastCol
If InStr(1, .Cells(7, i), specifiedDate, vbTextCompare) = 0 Then
.Columns(i).Delete
i = i - 1
lastCol = lastCol - 1
Else
Exit For
End If
Next i
End With
End Sub
Something like... You need to call it from somewhere else, using syntax like DeleteUnnecessaryColumns "Sheet1", "9/30/2017"
Sub DeleteUnnecessaryColumns(specifiedWorksheet as worksheet, SpecifiedDate as string)
dim r as range ' set up a range for row 7, columns C to the end
set r = specifiedWorksheet.rows(7)
set r = r.resize(Columnsize:= r.columns.count - 2)
set r = r.offset(0,2)
Dim lastCol As Long, i as long
for i = 1 to r.columns.count 'loop through the cells in the r range
if instr(string:=r.cells(i), substring:= SpecifiedDate) > 0 then
lastcol = i 'this ends the loop and sets the value for lastcol
end if
next
SpecifiedWorksheet.range(cells(1, 3), cells(1, lastcol - 1).entirecolumn.delete
End Sub
I'm trying to use the trim function without success. After searching for the solution on this forum and other sources online I have seen many different approaches.
Is there no simple way of trimming a cell in VBA?
What I want is something like this:
Sub trimloop()
Dim row As Integer
row = 1
Do While Cells(row, 1) <> ""
Cells(row, 2) = trim(Cells(row, 2))
row = row + 1
Loop
So that when there is a value in column A (1) the value in column B (2) should be trimmed of any extra spaces. I just cant get this to work for me.
Appreciate any help/tips!
Regards
Jim
So i made the code a bit accurate and mistakeproof and it worked.
So i can recommend you to double check, if you have correct row and column values, because you probably targeting wrong cells. (cause your code is working)
Sub trimloop()
Dim row As Integer
Dim currentSheet As Worksheet
Set currentSheet = sheets("Sheet1")
row = 2
Do While currentSheet.Cells(row, 1) <> ""
currentSheet.Cells(row, 2).Value = Trim(currentSheet.Cells(row, 2).Value)
row = row + 1
Loop
End Sub
Use Application.WorksheetFunction.Trim(string)
Sub trimloop()
Dim row As Integer
row = 1
With ThisWorkbook.ActiveSheet
Do While .Cells(row, 1) <> ""
.Cells(row, 2) = Application.WorksheetFunction.Trim(.Cells(row, 2))
row = row + 1
Loop
End With
End Sub
this is the optimized version of your code, in case of big data sheets:
Option Explicit
Sub trimloop()
Dim row As Long, max As Long
Dim Data() As Variant
With ThisWorkbook.Sheets(1)
max = .Cells(1, 1).End(xlDown).row 'this does the same as your code, on first empty cell it stops
'the following finds the last un-empty cell of column(1):
'max= .cells(.rows.count,1).end(xlup).row
'copies values from sheet to memory (is faster for working with later)
Data = .Range(.Cells(1, 1), .Cells(max, 2)).Value2
'loop :
For row = 2 To max + 1
'work with memory instead of sheet
Data(row, 2) = Trim(Data(row, 2))
'for complete delete of all spaces use : = replace( StringName," ", "")
Next row
'write back to sheet
.Range(.Cells(1, 1), .Cells(max, 2)).Value2 = Data
End With
erase Data 'free memory
End Sub
Don't know if this overly simplified... but thought I would simply throw it out there this worked for me. The only predecessor step is you assign a "named range" to your workbook/worksheet/dataset ... name a data set and then iterate over the data set with this code
Sub forEachLoop()
For Each cell In Range("yourNamedRange")
cell.Value = Trim(cell.Value)
Next cell
End Sub
I need to search for duplicate values and mark them in an Excel spreadsheet. I have my data to verify in column D and the data where possible duplicates are in column K. I need to check for each row in column D all the rows in col. K.
This is my current script for this:
Sub MySub()
Dim ThisCell1 As Range
Dim ThisCell2 As Range
For Each ThisCell1 In Range("D1:D40000")
'This is the range of cells to check
For Each ThisCell2 In Range("K1:K40000")
'This is the range of cells to compare
If ThisCell1.Value = ThisCell2.Value Then
If ThisCell1.Value <> "" Then
ThisCell1.Interior.ColorIndex = 3
End If
Exit For
End If
Next ThisCell2
Next ThisCell1
End Sub
The problem with this is that it's VERY slow. I mean it takes hours to check the data which is not acceptable. Even when the range is set to 1:5000, it still takes 10-15 minutes to finish. Is there any way to make it faster?
A dictionary will be the fastest way to achieve what you are looking for. Don't forget to add a reference to the 'microsoft scripting runtime' in your project
Sub MySubFast()
Dim v1 As Variant
Dim dict As New Scripting.Dictionary
Dim c As Range
v1 = Range("D1:D40000").Value
For Each c In Range("K1:K40000")
If Not dict.Exists(c.Value) Then
dict.Add c.Value, c
End If
Next
Dim i As Long
For i = LBound(v1, 1) To UBound(v1, 1)
If v1(i, 1) <> "" Then
If dict.Exists(v1(i, 1)) Then
Range("D" & i).Interior.ColorIndex = 3
End If
End If
Next i
End Sub
note : this is an improvement of #Jeanno answer.
Use arrays instead of referencing objects (Ranges) way faster.
Sub MySubFast()
Dim v1 As Variant
Dim v2 As Variant
v1 = Range("D1:D40000").Value
v2 = Range("K1:K40000").Value
Dim i As Long, j As Long
For i = LBound(v1, 1) To UBound(v1, 1)
For j = LBound(v2, 1) To UBound(v2, 1)
If v1(i, 1) = v2(j, 1) Then
If v1(i, 1) <> "" Then
Range("D" & i).Interior.ColorIndex = 3
End If
Exit For
End If
Next j
Next i
End Sub
Aren't you just highlighting cells in column D if the value exists in column K? No need for VBA for this, just use conditional formatting.
Select column D (selecting the whole column is fine)
Add a conditional format using this formula: =COUNTIF($K:$K,$D1)>0
The conditional format will apply and update automatically as you change data in columns D and K, and it should be basically instant
I am trying to count the number of cells in a range that has the same color as a reference cells, IF the corresponding cell in another range has the correct value criterion. For example:
If (A1 < 350) and (B1 has the same color as a reference cell), then count 1.
Loop over rows 1 to 15
It is essentially the same problem as the question posted here:
http://www.mrexcel.com/forum/excel-questions/58582-countif-multiple-criteria-one-being-interior-color.html
Unfortunately, it seems that the ExtCell.zip file no longer exit. Hence, I could not simply replicate the given solution. I tried to follow the same approach using the SUMPRODUCT function and I wrote a function for comparing cell color, but it did not work. I got the error "A value used in the formula is of the wrong data type." My code is as follow. I am using Excel 2007 on Windows 7. Any help is appreciated. Thanks!
=SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))
The formula above is keyed into a cell. B57:B65 contain some numerical values, while D57:D65 are colored cells. D307 is the reference cell with the correct color.
'' VBA function ColorCompare
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim CallerCols As Long 'find out the number of cells input by the user
'so as to define the correct array size
With Application.Caller
CallerCols = .Column.Count
End With
ReDim TFresponses(1 To CallerCols)
Dim Idx As Long
Idx = 1
For Each rCell In compareCells
If rCell.Interior.ColorIndex = refCell.Interior.ColorIndex Then
TFresponses(Idx) = 1
Idx = Idx + 1
Else
TFresponses(Idx) = 0
Idx = Idx + 1
End If
Next rCell
ColorCompare = TFresponses
End Function
There are a couple of issues in your code
You need to determine the size of compareCells, not the caller cell
You are considering columns, should be Rows (or Rows and Columns for maximum flexability)
There are a few optimisations you can make
Here's a refactored version of your Function
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range, rRw As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim rw As Long, cl As Long
Dim clr As Variant
clr = refCell.Interior.ColorIndex
ReDim TFresponses(1 To compareCells.Rows.Count, 1 To compareCells.Columns.Count)
rw = 1
For Each rRw In compareCells.Rows
cl = 1
For Each rCell In rRw.Cells
If rCell.Interior.ColorIndex = clr Then
TFresponses(rw, cl) = True
End If
cl = cl + 1
Next rCell
rw = rw + 1
Next rRw
ColorCompare = TFresponses
End Function
Note that while this will return a result for any shaped range, to be useful in SumProduct pass it a range either 1 row high or 1 column wide - just as your sample formula does.
Try this (updated for given formula: =SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))):
Sub test()
i = 57
While Not IsEmpty(Cells(i, 1))
If Cells(i, 2) < 350 And Cells(i, 4).Interior.ColorIndex = Cells(307, 4).Interior.ColorIndex Then 'replace with your reference cell
count = count + 1
End If
i = i + 1
Wend
End Sub