I'm using macros to quickly search a large table of student data and consolidate it into a single cell for use in seating plans (I'm a teacher). Most of it works but I have a problem with selecting just the data I need.
Steps:
1. Remove data.
2. Run a formula to check if students fit into particular groups and consolidate their information
3. Format
Different subjects and year groups have different layouts for their data and so this step is causing me problems. I've tried using absolute cell references in step 2 but this doesn't work as sometimes the information that should be in column D is in column E etc.
What I want to be able to do is have a macro that checks the first value in the column (ie the title) and if it doesn't match one of a predetermined list delete the whole column along with it's data.
Dim rng As Range
For Each rng In Range("everything")
If rng.Value = "Test" Or rng.Value = "Test1" Then
rng.EntireColumn.Hidden = True
End If
I think I could use something like this if I could change the output from hiding columns to deleting them?
re: What I want to be able to do is have a macro that checks the first value in the column (ie the title) and if it doesn't match one of a predetermined list delete the whole column along with it's data.
To delete all columns NOT WITHIN the list:
Sub del_cols()
Dim c As Long, vCOL_LBLs As Variant
vCOL_LBLs = Array("BCD", "CDE", "DEF")
With Worksheets("Sheet7") '<~~ set this worksheet reference properly!
For c = .Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
If IsError(Application.Match(.Cells(1, c), vCOL_LBLs, 0)) Then
.Columns(c).Delete
End If
Next c
End With
End Sub
To delete all columns WITHIN the list:
Sub del_cols()
Dim v As Long, vCOL_LBLs As Variant
vCOL_LBLs = Array("BCD", "CDE", "DEF")
With Worksheets("Sheet7") '<~~ set this worksheet reference properly!
For v = LBound(vCOL_LBLs) To UBound(vCOL_LBLs)
Do While Not IsError(Application.Match(vCOL_LBLs(v), .Rows(1), 0))
.Cells(1, Application.Match(vCOL_LBLs(v), .Rows(1), 0)).EntireColumn.Delete
Loop
Next v
End With
End Sub
Related
Am trying to make a VBA validation sheet on Excel to find all the cells that do not match a predefined pattern and copy it to another sheet
My pattern is "4 numbers/5 numbers"
Ex: 1234/12345 is accepted
2062/67943 is accepted
372/13333 is not accepted
1234/1234 is not accepted etc...
I tried to put the following in the conditions sheet : <>****/***** and <>????/????? and both did not work (am not sure about the correctness of the approach as am still a beginner in VBA)
For the code itself, this is what I wrote :
Sub GuaranteeElig()
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = SheetName
Sheets("MainSheet").UsedRange.AdvancedFilter Action:= _
xlFilterCopy,
CriteriaRange:=Sheets("ConditionsSheet").Range("B1:B2"), _
CopyToRange:=Range("A1"), Unique:=False
End Sub
Any tips on how I can do it ?
Thanks in advance :)
As long as the values of the numbers are independent and do not matter, and it is only the Length of the numerical strings that count, you could use a for loop on the cells from the "search" sheet (I assume this is the MainSheet as shown in your code?) where your values are contained.
From there, I'll give you a couple ways to place the data in the validation sheet (assuming this is your ConditionsSheet as shown in your code?) where you are trying to pinpoint the values.
(You may need to change part of your approach depending on how you want the incorrect set of values laid out on your secondary sheet - but this should get you started.) I added a TON of comments as you say you're new to VBA - these will help you understand what is being done.
Sub GuaranteeElig()
'Adding this to help with performance:
Application.ScreenUpdating = False
'Assuming you are adding a sheet here to work with your found criteria.
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ConditionsSheet"
'Using the naming bits below I am assuming the data you are searching for is on MainSheet
'Get used range (most accurate and efficient way I have found yet, others on S.O.
'may have better ways for this - research it if this does not work for you)
'I have had problems using the Sheets().UsedRange method.
Dim c as Long 'This may not be necessary for you if you are looping through only column "A"
Dim r as Long
'Cells(y,x) method uses numerical values for each row (y) or column (x).
c = Cells(1, Columns.Count).End(xlToLeft).Column 'May not be necessary depending on your needs.
'Using this because you have "UsedRange" in your
'code.
'.End(xlToLeft) signifies we are going to the end of the available cell range of
'Row 1 and then performing a "Ctrl+Left Arrow" to skip all blank cells until we hit
'the first non-blank cell.
r = Cells(Rows.Count, 1).End(xlUp).Row
'.End(xlUp) method is similar - we go to the end of the available cell range for the
'column ("A" in this case), then performing a "Ctrl+Up Arrow" to skip all blank cells.
'If you have a header row which spans across the sheet, this is your best option,
'unless you have 'helper' cells which extend beyond the final column of this header
'row. I am assuming Row 1 is a header in this case - change to your needs.
'For your Rows - choose the column which contains congruent data to the bottom of
'your used range - I will assume column 1 in this case - change to suit your needs.
Dim i as long
Dim j as integer
Dim cel as Range
Dim working_Str() as String 'String Array to use later
Dim string1 as String
Dim string2 as String
Dim badString as Boolean
For i = 2 to r Step 1 'Step down from row 2 to the end of data 1 Row at a time
'Row 1 is header.
set cel=Cells(i, 1) 'Sets the cell to check - assuming data is in Column "A"
'i will change from for loop so 'cel' changes from "A2555"
'to "A2554" to "A2553" etc.
working_Str=Split(cel.Value, "/", -1) 'Splits the value based on "/" inside of cel
string1=working_Str(0) 'what we hope will always be 4 digits
string2=working_Str(1) 'what we hope will always be 5 digits
If Len(string1)<>4 Then 'string1 _(xxxx)_(/)(don't care) does not equal 4 digits in length
badString = True
Elseif Len(string2)<>5 Then ''string1 (don't care)(/)_(xxxxx)_ does not equal 5 digits in length
badString = True
End If
If badString Then 'If either strings above were not correct length, then
'We will copy cell value over to the new sheet "ConditionsSheet"
'Comment the next 2 commands to change from going to one row at a time to
'Matching same row/Cell on the 2nd sheet. Change to suit your needs.
j = j + 1 'Counter to move through the cells as you go, only moving one cell
'at a time as you find incorrect values.
Sheets("ConditionsSheet").Range("A" & j).Value=cel.Value 'sets the value on other sheet
'UNComment the next command to change from going to one row at a time to
'matching same row/cell on the 2nd sheet. Change to suit your needs.
'Sheets("ConditionsSheet").Range("A" & i).Value=cel.Value
End if
badString = False 'resets your boolean so it will not fail next check if strings are correct
Next i
'Returning ScreenUpdating back to True to prevent Excel from suppressing screen updates
Application.ScreenUpdating = True
End Sub
UPDATE
Check the beginning and ending lines I just added into the subroutine. Application.ScreenUpdating will suppress or show the changes as they happen - suppressing them makes it go MUCH quicker. You also do not want to leave this setting disabled, as it will prevent Excel from showing updates as you try to work in the cell (like editing cell values, scrolling etc. . . Learned the hard way. . .)
Also, if you have a lot of records in the given row, you could try putting the data into an array first. There is a great example here at this StackOverflow Article.
Accessing the values of a range across multiple rows takes a LOT of bandwidth, so porting the range into an Array first will make this go much quicker, but it still may take a bit. Additionally, how you access the array information will be a little different, but it'll make sense as you research it a little more.
Alternative To VBA
If you want to try using a formula instead, you can use this - just modify for the range you are looking to search. This will potentially take longer depending on processing speed. I am entering the formula on 'Sheet2' and accessing 'Sheet1'
=IF(COUNTIF(Sheet1!A1,"????/?????"),1,0)
You are spot on with the search pattern you want to use, you just need to use a function which uses wildcard characters within an "if" function. What you do with the "If value is true" vs "If value is false" bits are up to you. COUNTIF will parse wildcards, so if it is able to "count" the cell matching this string combination, it will result in a "True" value for your if statement.
Regex method, this will dump the mismatched value in a worksheet named Result, change the input range and worksheet name accordingly.
In my testing, 72k cells in UsedRange takes about 4seconds~:
Option Explicit
Sub GuaranteeElig()
Const outputSheetName As String = "Result"
Dim testValues As Variant
testValues = ThisWorkbook.Worksheets("MainSheet").UsedRange.Value 'Input Range, change accordingly
Const numPattern As String = "[\d]{4}\/[\d]{5}"
Dim regex As Object
Set regex = CreateObject("VBScript.Regexp")
regex.Pattern = numPattern
Dim i As Long
Dim n As Long
Dim failValues As Collection
Set failValues = New Collection
'Loop through all the values and test if it fits the regex pattern - 4 digits + / + 5 digits
'Add the value to failValues collection if it fails the test.
For i = LBound(testValues, 1) To UBound(testValues, 1)
For n = LBound(testValues, 2) To UBound(testValues, 2)
If Not regex.Test(testValues(i, n)) Then failValues.Add testValues(i, n)
Next n
Next i
Erase testValues
Set regex = Nothing
If failValues.Count <> 0 Then
'If there are mismatched value(s) found
'Tranfer the values to an array for easy output later
Dim outputArr() As String
ReDim outputArr(1 To failValues.Count, 1 To 1) As String
For i = 1 To failValues.Count
outputArr(i, 1) = failValues(i)
Next i
'Test if output worksheet exist
Dim outputWS As Worksheet
On Error Resume Next
Set outputWS = ThisWorkbook.Worksheets(outputSheetName)
On Error GoTo 0
'If output worksheet doesn't exist, create a new sheet else clear the first column for array dump
If outputWS Is Nothing Then
Set outputWS = ThisWorkbook.Worksheets.Add
outputWS.Name = outputSheetName
Else
outputWS.Columns(1).Clear
End If
'Dump the array starting from cell A1
outputWS.Cells(1, 1).Resize(UBound(outputArr, 1)).Value = outputArr
Else
MsgBox "No mismatched value found in range"
End If
Set failValues = Nothing
End Sub
If you do not need duplicate values in the list of mismatched (i.e. unique values) then sound out in the comment.
I have written a bunch of VBA macros to get my data formatted how I need it, and the last step is to sort by this new column I have generated in ascending order. However, when I hit sort by the new column, the code now places all the empty cells above my newly generated column as I think it is reading the empty as a 0 and sorts it above any alphanumeric data. This is happening because of the UDF I have for sorting the data. I need to insert the new column with the UDF for each new cell that I insert, but I don't know how to define the range in the new column.
I am close to solving this but would love some help.
Essentially what I have tried for placing the data in a new column works, but the way I have set the range is placing it in a bad spot and it can easily be sorted in the wrong order now. I include all of my code, but the issue is in the last portion of it where I am setting a range to place the new data.
I think what is happening is when I set my range from C3-C2000 and populate it, the remaining empty cells are now included in my sort and give me "lower" numbers when I sort it ascending. Thus all the empty cells are ranked higher up in the column.
Option Explicit
Sub ContractilityData()
Dim varMyItem As Variant
Dim lngMyOffset As Long, _
lngStartRow As Long, _
lngEndRow As Long
Dim strMyCol As String
Dim rngCell As Range
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'make new column for the data to go
lngStartRow = 3 'Starting row number for the data. Change to suit
strMyCol = "A" 'Column containing the data. Change to suit.
Application.ScreenUpdating = False
For Each rngCell In Range(strMyCol & lngStartRow & ":" & strMyCol & Cells(Rows.Count, strMyCol).End(xlUp).Row)
lngMyOffset = 0
For Each varMyItem In Split(rngCell.Value, "_") 'put delimiter you want in ""
If lngMyOffset = 2 Then 'Picks which chunk you want printed out (each chunk is set by a _ currently)
rngCell.Offset(0, 1).Value = varMyItem
End If
lngMyOffset = lngMyOffset + 1
Next varMyItem
Next rngCell
Application.ScreenUpdating = True
'Here is where my problem arises
Range("C:C").EntireColumn.Insert
Dim sel As Range
Set sel = Range("C3:C2000")
sel.Formula = "=PadNums(B3,3)"
MsgBox "Data Cleaned"
End Sub
What I would like instead is a way to insert a new column, then have my UDF "PadNums" populate each cell up to the last cell of the previous column, essentially re-naming all my data from the previous column. I can then sort by the new column in ascending order and my data is in the correct order.
I think perhaps what I should do is copy column B into my newly inserted column C, then use some sort of last row function to apply the formula in all cells. That would give me the appropriate range always based on my original column?
I solved this! What I did was use range and xlDown to last row on column B, then pasted it to C, then inserted my UDF into C using the xlDown range!
I have written VBA code that copies a filtered table from one spreadsheet to another. This is the code:
Option Explicit
Public Sub LeadingRetailers()
Dim rngRows As Range
Set rngRows = Worksheets("StoreDatabase").Range("B5:N584")
With rngRows
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets("LeadingRetailersAUX").Range("B2")
End With
Sheets("Leading Retailers").Activate
End Sub
The filter is applied before the code is ran and then the code selects the visible cells and copies them so as to get only those rows that passed the filter.
In the filtered table to be copied I have, in column L of the range, a certain set of names, some of which are repeated in several rows.
I would like to add to the code so that it only copies one row per name in column L. In other words, I would like the code to copy only the first row for each of the names that appears in Column L of the filtered table.
Pehaps something like this can help you. Code will loop through your rows (5 to 584). First it checks if row is hidden. If not, will check if the value in column "L" is already in the Dictionary. If it is not, it will do two things: copy the row to Destination Sheet, and add the value to the Dictionary.
Option Explicit
Public Sub LeadingRetailers()
Dim d As Object
Dim i As Long
Dim k As Long
Set d = CreateObject("scripting.dictionary")
i = 2 'first row of pasting (in "LeadingRetailersAUX")
For k = 5 To 584
If Not (Worksheets("StoreDatabase").Rows(k).RowHeight = 0) Then 'if not hidden
If Not d.Exists(Worksheets("Hoja1").Cells(k, 12).Value) Then 'if not in Dictionary
d.Add Worksheets("StoreDatabase").Cells(k, 12).Value, i 'Add it
Worksheets("LeadingRetailersAUX").Cells(i, 2).EntireRow.Value = Worksheets("StoreDatabase").Cells(k, 1).EntireRow.Value
i = i + 1
End If
End If
Next
End Sub
You could apply another filter to the table to only show the first occurrence of each set of names and then run your macro as usual. See this answer:
https://superuser.com/a/634284
I have a three excel files (A, B and C). And I have to compare A list to other lists to find if B and C list have same parts than A. Then have a separate list of parts that can be found list A and (B or C). Also it would be good if in the list have info Which one list (b or C) part have found.
In the lists column 1 is ID number and column 2 is part name.
Now I have tried following code:
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Sheet1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("A1:B" & TotalRows).Copy Destination:=Sheets("Sheet3").Range("A1")
'Go to the destination sheet
Sheets("Sheet3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Sheet2").UsedRange.Find(Cells(i, 1), LookAt:=xlWhole)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 4).Value = rng.Value
End If
Next
End Sub
But it's not very good for me. Because now I have to copy B and C list in sheet 2 and then this code copies all A list to sheet 3 and next column what are common with sheet2.
And do I have to say there are thousands of parts.
Even easy way to comparing B to A list would be good.
So I really need your help.
Microsoft Query to the rescue (Data->From Other Sources->Microsoft Query).
Example for comparing Sheets A and B
Step 1: Add a Row Number column to sheets A and B
Step 2: Create the query:
SELECT SheetA.A, SheetB.B FROM [SheetA$] as SheetA,
LEFT OUTER JOIN [SheetB$] as SheetB ON SheetA.A = SheetB.B
What if they are in different files?
SELECT SheetA.A, SheetB.B FROM `C:\FileA.xlsx`.`SheetA$` as SheetA,
LEFT OUTER JOIN `C:\FileA.xlsx`.`SheetA$` as SheetB ON SheetA.A = SheetB.B
As always I recommend using my AddIn to create the queries: link or use the Wizard (Data->From Other Sources->Microsoft Query).
I have 3 columns in Excel 2010 with email addresses, I need to be able to narrow all 3 columns to only have unique values. I don't necessarily need to merge the remaining values into a single column, but I definitely need to eliminate duplicates. I found another post that had a VB with it, but it didn't seem to work. It removed only a few duplicates:
Sub removeDuplicates()
Dim lastCol As Integer
lastCol = 5 'col 5 is column E
Dim wks As Worksheet
Set wks = Worksheets("Sheet1")
Dim searchRange As Range
Set searchRange = wks.Range("A1:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row)
Dim compareArray As Variant
Dim searchArray As Variant
'Get all values from Col A to search against
compareArray = searchRange.Value
For col = lastCol - 1 To 1 Step -1
'Set values to search for matches
searchArray = searchRange.Offset(0, col - 1).Value
'Set values to last column to compare against
compareArray = searchRange.Offset(0, col).Value
For i = 1 To UBound(compareArray)
If compareArray(i, 1) = searchArray(i, 1) Then
'Match found, delete and shift left
Cells(i, col).Delete Shift:=xlToLeft
End If
Next i
Next col
End Sub
Thanks!
Here is how I would propose doing this if it is a one-off task that you don't have to do very often.
Rather than typing out the entire process in detail, I have done a screencast of how I did this (and the entire process barely took me a minute to do).
The quick overview:
You will need to add a few temporary helper columns for unique values from each email list (one for each list), a 'merged list' column and then a final column. Filter for the unique emails using the 'Advanced' filter option one column at a time. Paste those values into the temporary column for that email list and then clear the filter. Repeat until you have gone through each column and each temporary column has the unique values in it from each list. Once you have the uniques from each list, paste these one at a time into the 'merged list' column (stacking the results in one long list) and then do a unique filter on that. Copy/paste the uniques from that list into your final column, clear the filter, and you're done.
Screencast is below:
http://screencast.com/t/zL8VmUut
Cheers!
Since the first column are the ones you already contacted, swap the first column with the second and on the 3rd write a YES or NO value if email was found on the second column (the ones you already contacted).
Formula.
=IF(ISERROR(VLOOKUP(A2,$B$2:$B$11,1,FALSE)),"Not Contacted","Yes")
As you can see, the one with Yes status is on the contacted list, you just filter the Not Contacted and you will have a new pending list in column A.
Simple.