I am new to VBA and macro. I will try to explain what I am trying to create then I will explain what problem I have with it.
There are two sheets in my Excel; 'Sheet 1' and 'Sheet 2'.
Sheet 1 is full of data. This data goes from column A to AK and there are 4206 rows.
Sheet 2 only consist an input cell box with a 'GO' button next to the box. The button is assigned to a macro.
What do I want to create?
In the input cell box I type something like 'GB' and then press the 'GO' button. The 'GO' button will look through Sheet 1 for cells with 'GB' in them. There are two particular columns that could have 'GB' in them; one of them is column K and one is column L. The 'GO' button will look in those two columns for 'GB' and filter the rows.
Important note: I don't want to design a macro so that they will look for 'GB' in column K and column L. Instead I want them to look for 'GB' in column K or column L.
What did I create?
I designed a macro and assigned it to the 'GO' box. This is the code that I put in:
Option Explicit
Sub Macro1()
'
' Macro1 Macro
'
Sheets("Sheet 1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Range("A12:AM4216").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("A1:AK2"), Unique:=False
End Sub
What works with the code? And what is the problem?
The code will return rows that has 'GB' in column L. This is great. However, I am looking of ways how to change the code so that it will return rows that has 'GB' in column K or column L.
Any advice on this please?
Thank you.
I think something like this should probably do it. I was a little confused on whether the 'GB' was something that would vary or if it would be the same every time, so I included the option for both (by default the code assumes it's static). I also didn't know if you wanted it case-sensitive, so by default, it is NOT case sensitive (to make it case-sensitive, remove the LCase functions).
Sub Macro1()
Dim ws As Worksheet
Dim firstRow As Long, lastRow As Long
Dim firstCol As String, secondCol As String
Dim findStr As String
Dim x As Long
'define worksheet to check
Set ws = ActiveWorkbook.Sheets("Sheet1") 'or whichever sheet
'define search string to check for based on static value
findStr = "GB"
'define search string to check for based on cell value
'findStr = ws.cells("A1") 'or whichever cell
'define start and end rows to loop through
firstRow = 12
lastRow = 4216
'define columns to check
firstCol = "K"
secondCol = "L"
'turn off screenupdating
Application.ScreenUpdating = False
'unhide rows in range
ws.Range(ws.Rows(firstRow).EntireRow, ws.Rows(lastRow).EntireRow).Hidden = False
'loop through the rows
For x = firstRow To lastRow
'if either cell has the search string in it (regardless of case)...
If InStr(LCase(ws.Range(firstCol & x)), LCase(findStr)) Or InStr(LCase(ws.Range(secondCol & x)), LCase(findStr)) Then
'...do nothing
Else
'...otherwise, hide the row
ws.Rows(x).EntireRow.Hidden = True
End If
Next x
'turn screenupdating back on
Application.ScreenUpdating = True
End Sub
Please note that like Cyril mentioned above, this is not a true filter: it just hides rows that don't match the specified criteria.
Related
If Worksheets("Data").Range("D5").value = 0 Then
Columns("K").EntireColumn.Hidden = True
Else
Columns("K").EntireColumn.Hidden = False
End If
Sir, I have the above code where Column "K" is hide/unhide based on the cell "D5" of another sheet. But when I Add or Delete Column in my excel then my desired column no. shift to "L" or "J" but column "K" static in VBA and hide by this code which should not happen. How this column "K" automatically change when a column delete or add in excel
I would suggest that you put a name ("Named Range") to the top cell of the column you want to show/hide. Then you can access this named Range in the code.
Assuming you defined the name "Homeloan" on Cell K1: write
Range("HomeLoan").EntireColumn.Hidden = False
Note that you should always qualify the Excel objects so that it is clear which worksheet you want to access, but that's not part of your question
If you don't have problem to unhide all the columns before searching for the word "Homeloan" this should work even if you delete or add columns.
Sub test()
Dim lcol As Long
With Worksheets("Data")
.Columns("A:AC").EntireColumn.Hidden = False 'Unhide all the columns first
'This only works if the column with the word homeloan is not hidden.
lcol = Application.WorksheetFunction.Match("Homeloan", .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column)), 0) 'Find last column in row 1. Then create a range to look for the word "Homeloan". Last, return the current column number where Header "Homeloan" exists.
If .Range("D5").Value = 0 Then
.Columns(lcol).EntireColumn.Hidden = True
Else
.Columns(lcol).EntireColumn.Hidden = False
End If
End With
End Sub
Background: This is my first time dealing with macros. I will have two worksheets that I’ll be using. The first sheet, ‘Source’ will have data available. The second sheet, ‘Final’ will be blank and is going to be where the macro will be pasting the data I’d like it to collect from the ‘Source’ sheet.
* I want the macro to find the specified header in the ‘Source’ sheet, copy that cell containing the header all the way down to the last row of existing data (instead of the entire column), and paste it onto the ‘Final’ sheet in a specified column (A, B, C, etc.). *
The reason why I have to specify which headers to find is because the headers in the ‘Source’ sheet won’t always be in the same position, but the ‘Final’ sheet’s headers will always be in the same position – so I CAN’T just record macros copying column A in ‘Source’ sheet and pasting in column A in ‘Final’ sheet. Also, one day the ‘Source’ sheet may have 170 rows of data, and another day it may have 180 rows.
Although, it would probably be best to copy the entire column since one of the columns will have a few empty cells rather than to the last row of existing data. I’m assuming it would stop copying when it reaches the first empty cell in the column chosen which would leave out the remaining data after that empty cell in the column – correct me if I’m wrong. If copying the entire column is the best way, then, please provide that as part of the possible solution. I’ve attached an example of the before & after result I would like accomplished:
Example of Result
Find Header=X, copy entire column -> Paste into A1 in ‘Final’ sheet
Find Header=Y, copy entire column -> Paste into B1 in ‘Final’ sheet
Etc..
I’m sorry if my wording isn’t accurate – I tried to explain the best I could. It’d be awesome if someone could help me out on this! Thanks!
u can try with this. i think its clear and step-by-step. it can be very optimized, but to start with vba i think its better this way.
the name of the column must be the same in both sheets.
Sub teste()
Dim val
searchText = "TEXT TO SEARCH"
Sheets("sheet1").Select ' origin sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
x = Selection.Columns.Count ' get number of columns
For i = 1 To x 'iterate trough origin columns
val = Cells(1, i).Value
If val = searchText Then
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("sheet2").Select ' destination sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
y = Selection.Columns.Count ' get number of columns
For j = 1 To y 'iterate trough destination columns
If Cells(1, j).Value = searchText Then
Cells(1, j).Select
ActiveSheet.Paste
Exit Sub
End If
Next j
End If
Next i
End Sub
good luck
I modified an answer I gave to another user with similar problem for your case,
I use dictionary function in most of my data sheets so that I can shift columns around without breaking the code, the below code you can shift your columns around and it will still work
the only main restriction is
1. your header names must be unique
2. your header name of interest must be exactly the same.
i.e. your source header of interest is PETER then your Data table should have a header with PETER and it must be unique.
Sub RetrieveData()
Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1 'set the header row in sheet A
TableColStart_A = 1 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column 'Get number of NAMEs you have
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then 'check if the name exists in the dictionary
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
End If
Next i
End With
With ws_B 'worksheet you want to paste data into
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
For i = 1 To ws_B_lastCol 'for each data
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value)) 'get the column where the name is in Sheet A from the dictionaary
If SourceCol_A <> 0 Then 'if 0 means the name doesnt exists
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
Next i
End With
End Sub
Concept:
Entire Rows are deleted through a macro based off parameters which are represented as an excel formula by the user. The idea here is that a user can use Boolean formulas that they're already familiar with to evaluate values in a range (read the "Process" below for further clarification).
Process:
A user clicks on a button which shows a form. This form contains two input fields (or parameters); "Column" and "Formula". The "Column" is the range for which the macro will be cycling through (let's say $A:$A). The "Formula" is an Excel based formula represented as such, in the user parameter field ie =OR(A1="X",A1="Y"). However, I've instructed the user to replace any instance of A1 with rng. I've requested the user to do this because the idea here is that I would replace rng with a changing variable in VBA that cycles through all the cells specified in the "Column" parameter.
Problem:
I'm not aware of any way to replace the rng representation within the Excel formula with a range variable in VBA.
Update 4-7-17
Thank you all for your responses but I'm pretty certain my problem is getting lost in translation. I'm aware this is my fault, since I didn't provide any code for analysis. Unfortunately, therein lies the issue. I don't know what to write. I'm going to do my best to write some code (that I know is wrong) which will hopefully convey what I'm trying to accomplish.
Sample Code 4-7-17
Sub SampleCode()
Dim wRng As Range
Set wRng = Range("A1:A26") 'Let's assume that the values in this range are the
' letters of the alphabet
Dim Counter As Integer
'Cell "B2" will contain a formula that the user has entered
'which is: =OR(rng="X",rng="M")
'Obviously the formula returns an error in excel (#NAME? to be
'exact) but that's understood.
Dim wFormula As String
wFormula = Range("B2").Formula
Dim rng As Range 'This variable "rng" is what is represented in the
'formula that was written in Range("B2")
'*** This is where I get stuck. I know I'm missing code here to
'be able to proceed with my routine below.
'code
'code
'code
Counter = wRng.Rows.Count
For i = 1 To wRng.Rows.Count
Set rng = Cells(Counter, 1)
If wFormula = True Then
rng.EntireRow.Delete
End If
Counter = Counter - 1
Next i
'The ending result should be that row 24 was deleted because it contained
'the letter "X" and row 13 was deleted because it contained the letter "M"
'
'The objective of this code is to use any Excel formula which evaluates out
'to a True or False value.
End Sub
Hey Jon first you need to declare a Variable of relevant data type, then pass value from Range & finally use where you wish to, like,
Dim Src As Variant
Src= Sheets( "Sheet3" ).Range( "A2:A9" ).Value
Hey John this code will help you to get the solution,
Public Sub ProcessData()
Const TEST_COLUMN As String = "A"
Dim Lastrow As Long Dim i As Long
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = Lastrow To 1 Step -1
If Cells(i, TEST_COLUMN).Value2 Like "AU" Or _ Cells(i, TEST_COLUMN).Value2 Like "AZ" Then
.Rows(i).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
i'm fairly new to VBA and could do with a bit of help. I've looked online and i've found a few bits of code but have been unable to amend to my needs.
I'm trying to create a macro that will enable me to see if their are any duplicate text between column A and B and if the text in column A matches Column B then we will need to delete the entire row. The columns are on the same sheet
I am trying to create a loop that will do this. I must also point out that the length of the list does increase every week
I would appreciate any help
Thank you
Hi try in your code VBA:
Sub DeleteRowWithContents()
'========================================================================
' DELETES ALL ROWS FROM A2 DOWNWARDS WITH THE WORDs "Record Only" IN COLUMN D
'========================================================================
Last = Cells(Rows.Count, "D").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "D").Value) = "Record Only" Then
'Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
Cells(i, "A").EntireRow.Delete
End If
Next i
End Sub
you can update this code for your problem!
I use this when i need deletes all rows from a2 downwards with the words "record only" in column d.
Maybe try this:
Sub DeleteRowWithContents()
Dim ColumnAValue As String
Dim ColumnBValue As String
Dim xlWB As Worksheet
Set xlWB = ActiveWorkbook.ActiveSheet 'If it isn't the active sheet use second row:
'Set xlWB = ActiveWorkbook.Sheets("NameOfSheet") 'Change to the name of your sheet
For i = 1 To EOF 'This goes through the whole document to the last row automatically, EOF means "End Of File"
ColumnAValue = xlWB.Cells(i, 1).Value 'row i, column "a"
ColumnBValue = xlWB.Cells(i, 2).Value 'row i, column "b"
If (ColumnAValue = ColumnBValue) Then
xlWB.Range(ColumnAValue).Select
Selection.EntireRow.Delete 'NOTE!!
End If
Next i
End Sub
NOTE: I'm not too sure if this works, can't test it right now. IF it doesn't, try this instead:
EntireRow.Select
Selection.Delete
my data is as below .
Updated Question
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Sheet1") 'or other reference to data sheet
Dim coll As Collection, r As Range, j As Long
Dim myArr As Variant
Dim shNew As Worksheet
shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter
Set coll = New Collection
On Error Resume Next
For Each r In Range("A1:A10")
coll.Add r.Value, r.Value
Next r
On Error GoTo 0
'Debug.Print coll.Count
For j = 1 To coll.Count
MsgBox coll(j)
myArr = coll(j)
Next j
Range("a1").AutoFilter
Dim i As Long
For i = 0 To UBound(myArr)
shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
Operator:=xlAnd
On Error Resume Next
Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i)
Err.Clear
End If
Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter
End Sub
When I run above macro I don't know why it is giving Type Mismatch Error after MsgBox coll(j) , simply I want to store data in Array and I'm passing that data , Here I am using For Each r In Range("A1:A10") Where A10 length is static how can I find last written column?
When you add something to collection the key needs to be a string so use:
coll.Add r.Value, CStr(r.Value)
instead of:
coll.Add r.Value, r.Value
You are still assigning coll(j) to a Variant which is not an array.
You need to:
ReDim myArr(1 to coll.Count)
Before your for loop and then in the loop:
myArr(j) = coll(j)
Before attempting to respond to this question, I would like to write what I believe you are trying to accomplish; when you confirm this is what you are trying to do, I will try to help you get working code to achieve it. This would normally be done with comments, but the threads of comments so far are a bit disjointed, and the code is quite complex...
You have data in a sheet (called "sheet1" - it might be something else though)
The first column contains certain values that might be repeated
You don't know how many columns there might be... you would like to know that though
You attempt to find each unique value in column A (call it the "key value"), and display it (one at a time) in a message box. This looks more like a debug step than actual functionality for the final program.
You then turn on the autofilter on column A; selecting only rows that match a certain value
Using that same value as the name of a sheet, you see if such a sheet exists: if it does, you clear its contents; if it does not, then you create it at the end of the workbook (and give it the name of the key)
You select all rows with the same (key) value in column A on sheet1, and copy them to the sheet whose name is equal to the value in column A that you filtered on
You want to repeat step 5-8 for each of the unique (key) values in column A
When all is done, I believe you have (at least) one more sheet than you had key values in column A (you also have the initial data sheet); however you do not delete any "superfluous" sheets (with other names). Each sheet will have only rows of data corresponding to the current contents of sheet1 (any earlier data was deleted).
During the operation you turn autofiltering on and off; you want to end up with auto filter disabled.
Please confirm that this is indeed what you are attempting to do. If you could give an idea of the format of the values in column A, that would be helpful. I suspect that some things could be done rather more efficiently than you are currently doing them. Finally I do wonder whether the whole purpose of organizing your data in this way might be to organize the data in a specific way, and maybe do further calculations / graphs etc. There are all kinds of functions built in to excel (VBA) to make the job of data extraction easier - it's rare that this kind of data rearranging is necessary to get a particular job done. If you would care to comment on that...
The following code does all the above. Note the use for For Each, and functions / subroutines to take care of certain tasks (unique, createOrClear, and worksheetExists). This makes the top level code much easier to read and understand. Also note that the error trapping is confined to just a small section where we check if a worksheet exists - for me it ran without problems; if any errors occur, just let me know what was in the worksheet since that might affect what happens (for example, if a cell in column A contains a character not allowed in a sheet name, like /\! etc. Also note that your code was deleting "CurrentRegion". Depending on what you are trying to achieve, "UsedRange" might be better...
Option Explicit
Sub Solution()
Dim shData As Worksheet
Dim nameRange As Range
Dim r As Range, c As Range, A1c As Range, s As String
Dim uniqueNames As Variant, v As Variant
Set shData = Sheets("Sheet1") ' sheet with source data
Set A1c = shData.[A1] ' first cell of data range - referred to a lot...
Set nameRange = Range(A1c, A1c.End(xlDown)) ' find all the contiguous cells in the range
' find the unique values: using custom function
' omit second parameter to suppress dialog
uniqueNames = unique(nameRange, True)
Application.ScreenUpdating = False ' no need for flashing screen...
' check if sheet with each name exists, or create it:
createOrClear uniqueNames
' filter on each value in turn, and copy to corresponding sheet:
For Each v In uniqueNames
A1c.AutoFilter Field:=1, Criteria1:=v, _
Operator:=xlAnd
A1c.CurrentRegion.Copy Sheets(v).[A1]
Next v
' turn auto filter off
A1c.AutoFilter
' and screen updating on
Application.ScreenUpdating = True
End Sub
Function unique(r As Range, Optional show)
' return a variant array containing unique values in range
' optionally present dialog with values found
' inspired by http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array
Dim d As Object
Dim c As Range
Dim s As String
Dim v As Variant
If IsMissing(show) Then show = False
Set d = CreateObject("Scripting.Dictionary")
' dictionary object will create unique keys
' have to make it case-insensitive
' as sheet names and autofilter are case insensitive
For Each c In r
d(LCase("" & c.Value)) = c.Value
Next c
' the Keys() contain unique values:
unique = d.Keys()
' optionally, show results:
If show Then
' for debug, show the list of unique elements:
s = ""
For Each v In d.Keys
s = s & vbNewLine & v
Next v
MsgBox "unique elements: " & s
End If
End Function
Sub createOrClear(names)
Dim n As Variant
Dim s As String
Dim NewSheet As Worksheet
' loop through list: add new sheets, or delete content
For Each n In names
s = "" & n ' convert to string
If worksheetExists(s) Then
Sheets(s).[A1].CurrentRegion.Clear ' UsedRange might be better...?
Else
With ActiveWorkbook.Sheets
Set NewSheet = .Add(after:=Sheets(.Count))
NewSheet.Name = s
End With
End If
Next n
End Sub
Function worksheetExists(wsName)
' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html
worksheetExists = False
On Error Resume Next
worksheetExists = (Sheets(wsName).Name <> "")
On Error GoTo 0
End Function