I am working on a macro that will consolidate two different sources of order data. The first source will contain old orders as well as some new, the second source will contain only the old orders and will have additional data in columns that were updated manually.
My idea for this is to take the order totals from the second source, paste them in a sheet after the order totals from the first source, and then search all the order numbers from the new file against the order numbers from the existing tracker. I have a for loop that is supposed to find the order numbers from the new file that are not already in the tracker and then insert a row with that order detail. I am receiving a Type mismatch error on the if statement that checks if the string exists in the array. Please take a look at this code:
Dim r As Integer
For r = 1 To 1000
Dim NewOrd As String
NewOrd = Range(Cells(r, 1), Cells(r, 1)).Value
Dim ExistArray As Variant
ExistArray = Range("a1", Range("a1").End(xlUp))
Sheets("Sheet2").Select
If IsEmpty(NewOrd) Then
Exit For
End If
If Not UBound(Filter(ExistArray, NewOrd)) >= 0 And NewOrd <> "" Then
Rows(r).Select
Selection.Copy
Sheets("Sheet3").Select
Rows(r).Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
End If
r = r + 1
Next r
I have tried a few different ways of setting the array, tried adding option explicit, and tried nesting for loops (not my brightest efficiency moment). Would greatly appreciate another set of eyes!
Thanks!
Assigning a Range object to an array always results in a two-dimensional array, which is causing the error.
Do this:
ExistArray = Application.Transpose(Range("a1", Range("a1").End(xlUp)))
I think that should resolve it for you.
Updates
You may need to:
Dim ExistArray() As Variant
Your range object is also problematic, being a single cell:
ExistArray = Application.Transpose(Array(Range("A1")))
Change the sheet names from "Sheet1" and "Sheet2" as necessary:
Sub tgr()
Dim wsNew As Worksheet
Dim wsTracker As Worksheet
Dim rIndex As Long
'This is the sheet that contains the new data that needs to be added
Set wsNew = Sheets("Sheet1")
'This sheet contains the old data
Set wsTracker = Sheets("Sheet2")
'Go through each row in the new data
For rIndex = 1 To wsNew.Cells(Rows.Count, "A").End(xlUp).Row
'Verify that the row isn't blank and that it doesn't already exist in wsTracker
If Len(wsNew.Cells(rIndex, "A").Value) > 0 And WorksheetFunction.CountIf(wsTracker.Columns("A"), wsNew.Cells(rIndex, "A").Value) = 0 Then
'This is a new item that needs to be added
'Copy the row to the next available row in wsTracker
wsNew.Rows(rIndex).Copy wsTracker.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next rIndex
Set wsNew = Nothing
Set wsTracker = Nothing
End Sub
Related
Ok, this might take a bit to explain. I have a single MS Excel setting log sheet for a machine in our plant that contains setting specs for over 100 different part numbers built on that machine (each row is a different part number). We're switching to a new format that will have a separate sheet for each part number, with each sheet following a certain format (I set up a template beforehand and copied it for each part number). The first column of the old log sheet contains all of the part numbers, and the sheet names correspond to these part numbers.
So I'm trying to set up a program that will repeat for each part number (each sheet), and will find that number in the first column of the old log sheet. Then it will pull the value from the cell in, let's say, column B of that row, and will place that value in a specific cell in the sheet for that part number. Now, this will need to pull data from several cells for each part number, but if I can get it to work for one, I can go from there.
Here's what I've got so far:
Sub EditSettings()
Dim i As Integer
Dim j As Integer
Dim lastrow As Integer
lastrow = Sheets("M200 46mm Setting Log").Range("A" & Rows.Count).End(xlUp).Row
For i = 5 To Worksheets.Count
For j = 4 To lastrow
If Sheets("M200 46mm Setting Log").Cells(j, "A").Value = "" Then
ElseIf Sheets("M200 46mm Setting Log").Cells(j, "A").Value = Sheets(i).Name Then
Sheets("M200 46mm Setting Log").Range(j, "B").Copy _
Destination:=Sheets(i).Range("D11")
End If
Next
Next
End Sub
When I run this however, it gives me an error saying "Run-time error '1004': Application-defined or object-defined error".
This is easier than you might imagine. You don't need to loop through each of the worksheets because you can assign the target worksheet by its name: Set ws = WorkSheets([name as a string]). So you really only need to loop through the rows and pick up each sheet name.
I'd also recommend creating an address map of each old sheet cell and its new sheet cell address. In your example, column "B" goes to "D11", so create a collection of all of these and simply loop through them for the copying. There are quicker ways of doing it but with only 100 or so different parts it's not worth worrying about.
The code below shows you how to do both. From your question you mention that you have created templates for each new sheet. Presumably, then, the format is correctly set, so you've no need to do a copy/paste, just write each cell value to the new cell.
By the way, the most obvious error in your code (and probably the reason for your error) is that this line: Sheets("M200 46mm Setting Log").Range(j, "B").Copy ... should be Sheets("M200 46mm Setting Log").Cells(j, "B").Copy ...
Sub RunMe()
Dim wsLog As Worksheet
Dim wsPart As Worksheet
Dim sheetName As String
Dim addressMap As Collection
Dim map As Variant
Dim lastRow As Long
Dim r As Long
Set addressMap = New Collection
' Map the transfer cell addresses
addressMap.Add SetRangeMap("B", "D11")
' 1st item is old log sheet column, 2nd is address of new sheet
' ...
' ... repeat for all the address maps
' ...
'Loop through the rows in the source sheet
Set wsLog = ThisWorkbook.Worksheets("M200 46mm Setting Log")
lastRow = wsLog.Cells(wsLog.Rows.Count, "A").End(xlUp).Row
For r = 4 To lastRow
' Acquire the sheet name from the part number cell
sheetName = CStr(wsLog.Cells(r, "A").Value2)
' Try to assign the parts number worksheet
Set wsPart = Nothing
On Error Resume Next
Set wsPart = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
' If assigment worked then transfer data
If Not wsPart Is Nothing Then
For Each map In addressMap
wsPart.Range(map(1)).Value = wsLog.Cells(r, map(0)).Value2
Next
End If
Next
End Sub
Private Function SetRangeMap(sourceCol As String, partAddress As String) As Variant
Dim map(1) As String
map(0) = sourceCol
map(1) = partAddress
SetRangeMap = map
End Function
I want to copy some columns with headers from a worksheet to another one. I've created an array that looks for the different headers needed so I can copy and paste the entire column into the new tab. I know I have an error somewhere because I'm getting a type mismatch error and possibly other types as well. Can someone take a look and see what I'm missing/have wrong?
Dim rngCell As Range
Dim strHeader() As String
Dim intColumnsMax As Integer
Sheets.Add.Name = "Material Master"
Sheets.Add.Name = "BOM"
intColumnsMax = Sheets("HW Zpure Template").UsedRange.Columns.Count
ReDim strHeader(1 To intColumnsMax)
strHeader(1) = "MATERIAL"
strHeader(2) = "MATERIAL TYPE"
strHeader(3) = "MATERIAL DESCRIPTION"
For Each rngCell In Rows(4)
For i = 1 To intColumnsMax
If strHeader(i) = rngCell.Value Then
rngCell.EntireColumn.Copy
Sheets("Material Master").Select
ActiveSheet.Paste Destination:=Worksheets("Material Master").Cells(1, i)
Sheets("HW Zpure Template").Select
End If
Next i
Next
I prefer to use Application.Match to locate a specific column header label rather than cycling through them trying to find a match. To that end, I've heavily modified your code.
Dim c As Long, v As Long, vHDRs As Variant
Dim s As Long, vNWSs As Variant, wsMM As Worksheet
vHDRs = Array("MATERIAL", "MATERIAL TYPE", "MATERIAL DESCRIPTION")
vNWSs = Array("Material Master", "BOM")
For v = LBound(vNWSs) To UBound(vNWSs)
For s = 1 To Sheets.Count
If Sheets(s).Name = vNWSs(v) Then
Application.DisplayAlerts = False
Sheets(s).Delete
Application.DisplayAlerts = True
Exit For
End If
Next s
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = vNWSs(v)
Next v
Set wsMM = Sheets("Material Master")
With Sheets("HW Zpure Template")
For v = LBound(vHDRs) To UBound(vHDRs)
If CBool(Application.CountIf(.Rows(4), vHDRs(v))) Then
c = Application.Match(vHDRs(v), .Rows(4), 0)
Intersect(.UsedRange, .Columns(c)).Copy _
Destination:=wsMM.Cells(1, Application.CountA(wsMM.Rows(1)) + 1)
End If
Next v
End With
Set wsMM = Nothing
Correct me if I'm wrong, but your code seemed to be looking for the column labels in row 4. That is what I'm using above but if that assumption is incorrect then the fix should be fairly self-evident. I've also stacked the copied columns into the first available column to the right. Your code may have been putting them in the original position.
When you run the above, please note that it will remove worksheets named Material Master or BOM without asking in favor of inserting its own worksheets of those names. Given that, it's probably best to run on a copy of your original.
Using the Find() method is a very efficient way of finding the data you want. Below are a few suggestions to optimize your existing code.
Dim rngCell As Range
Dim strHeader() As String
Dim intColumnsMax As Integer
Dim i As Integer
Sheets.Add.Name = "Material Master"
Sheets.Add.Name = "BOM"
'Quick way to load a string array
'This example splits a comma delimited string.
'If your headers contain commas, replace the commas in the next line of code
'with a character that does not exist in the headers.
strHeader = Split("MATERIAL,MATERIAL TYPE,MATERIAL DESCRIPTION", ",")
'Only loop through the headers needed
For i = LBound(strHeader) To UBound(strHeader)
Set rngCell = Sheets("HW Zpure Template").UsedRange.Find(What:=strheader(i), LookAt:=xlWhole)
If Not rngCell Is Nothing Then
'Taking the intersection of the used range and the entire desired column avoids
'copying a lot of unnecessary cells.
Set rngCell = Intersect(Sheets("HW Zpure Template").UsedRange, rngCell.EntireColumn)
'This method is more memory consuming, but necessary if you need to copy all formatting
rngCell.Copy Destination:=Worksheets("Material Master").Range(rngCell.Address)
'This method is the most efficient if you only need to copy the values
Worksheets("Material Master").Range(rngCell.Address).Value = rngCell.Value
End If
Next i
I've looked around the forum and played with various options but not found a clear match for my problem:
My task is to copy data from a worksheet (called “workorders”) to a second worksheet (called “Assignments”). The data to be copied is from the “workorders” worksheet starting at cell range “E2, P2:S2”; and also copied from each row (same range) until column “P” is empty – (the number of rows to be copied can vary each time we need to run this macro so we can’t select a standard range) . Then pasted into the “Assignments” worksheet, starting at cell “A4”. I’ve used the forum so far to successfully copy a single row of date (from row 2) – I admit that’s the easy part, and I’ve used various versions of code to achieve this.
I’ve also tried some code (which I found via watching a youtube clip and modifying http://www.youtube.com/watch?v=PyNWL0DXXtQ )to allow me to run a loop which repeats the copy process for each required row in the “workorders” worksheet and then pastes the data into the “assignments” worksheet- but this is where I am not getting it right, I think I’m along the right lines and think I’m not far off but any help would be very useful.
Code examples below (first 2 only copy first row, 3rd example is where I’ve tried to loop and copy multiple rows:
Sub CopyTest1()
' CopyTest1 Macro
'copy data from workorders sheet
'Worksheets("workorders").Range("E2,P2,Q2,R2,S2").Copy
Worksheets("workorders").Range("E2, P2:S2").Copy
'paste data to assignments sheet
'sheets("assigments dc").Range("A4").Paste
Sheets("Assigments DC").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Sub CopyTest2()
Sheets("workorders").Range("e2,p2,q2,r2,s2").Copy Sheets("assigments dc").Range("a4")
End Sub
Sub CopyTest3()
Dim xrow As Long
'Dim xrow As String
xrow = 2
Worksheets("workorders").Select
Dim lastrow As Long
lastrow = Cells(Rows.Count, 16).End(xlUp).Row
Do Until xrow = lastrow + 1
ActiveSheet.Cells(xrow, 16).Select
If ActiveCell.Text = Not Null Then
'Range("E2,P2,Q2,R2,S2").Copy
'Selection = Range("E2,P2,Q2,R2,S2").Copy
'Cells(xrow, 5).Copy
Cells(xrow, 5).Copy
Sheets("Assigments DC").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("workorders").Select
End If
xrow = xrow + 1
Loop
End Sub
Try this:
Sub LoopCopy()
Dim shWO As Worksheet, shAss As Worksheet
Dim WOLastRow As Long, Iter As Long
Dim RngToCopy As Range, RngToPaste As Range
With ThisWorkbook
Set shWO = .Sheets("Workorders") 'Modify as necessary.
Set shAss = .Sheets("Assignments") 'Modify as necessary.
End With
'Get the row index of the last populated row in column P.
'Change accordingly if you want to use another column as basis.
'Two versions of getting the last row are provided.
WOLastRow = shWO.Range("P2").End(xlDown).Row
'WOLastRow = shWO.Range("P" & Rows.Count).End(xlUp).Row
For Iter = 2 to WOLastRow
Set RngToPaste = shAss.Range("A" & (Iter + 2))
With shWO
Set RngToCopy = Union(.Range("E" & Iter), .Range("P" & Iter & ":S" & Iter))
RngToCopy.Copy RngToPaste
End With
Next Iter
End Sub
Read the comments first and test.
Let us know if this helps.
From what I see, you are only copying the cell in Column E. You could correct this by replacing Cells(xrow, 5).Copy with
Union(Sheets("workorders").Cells(xrow,5),Sheets("workorders").Range(Cells(xrow,"P"),Cells(xrow,"S")).Copy
However, using Select and Copy are not ideal. Instead, you can assign the value of the range directly:
Sheets("Assignments DC").Range("A4").Value = Union(Sheets("workorders").Cells(xrow,5),Sheets("workorders").Range(Cells(xrow,"P"),Cells(xrow,"S")).Value
More info on the Union method and why using Select is bad.
Is it even possible to run a line like this?
Worksheets("workorders").Range("E2, P2:S2").Copy
Each time I try different ways to copy/select a range which contains in my case, A3 and the range A34:C40 ("A3, A34:C40").Copy i get an error saying theres to many parameters.. Could this be because I'm running excel 2007?
Any tips or help would be greatly apreciated! :)
I was wondering if there was a way to get all the different autofilter criteria in a list in order to iterate through each criteria, to in the end copy and paste each different table that would appear to a separate sheet as it iterates through.
Ideally this would be run n times:
ActiveSheet.Range(AllRows).AutoFilter Field:=10, Criteria1:=CritVariable
Where n is the number of different CritVariables there are.
I'd like to stress that I know how to copy and paste in the macro itself, but I was curious how to iterate through all the different criteria because the criteria could be different depending on the day. If a list of it isn't available how would I best go about iterating through the criteria?
You can study and adapt the following. Here is an outline of what is going on.
I have a staff-table starting at cell A5, with a list of Offices in
column G;
I'm copying from G5 downwards (assuming there are no blanks in this column's data) to W1;
From range W1 downwards I am removing duplicates;
Then I'm looping through this data, using Advanced Filter to copy the data for each office to an area starting at cell Z1;
This filtered data is then moved (Cut) to a new worksheet, which is named from the current Office name (the criteria);
After each Advanced Filter the cell W2 is deleted, making the value in W3 move up, so that it can be used for the next filter operation.
This does mean that when you press Ctrl-End to go to the last-used cell it goes further than it needs to. You can find a way to resolve this if necessary ;).
Sub SheetsFromFilter()
Dim wsCurrent As Worksheet
Dim wsNew As Worksheet
Dim iLeft As Integer
Set wsCurrent = ActiveSheet
Application.ScreenUpdating = False
Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
iLeft = Range("W1").CurrentRegion.Rows.Count - 1
Do While iLeft > 0
wsCurrent.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, _
wsCurrent.Range("W1:W2"), wsCurrent.Range("Z1")
Set wsNew = Worksheets.Add
wsCurrent.Range("Z1").CurrentRegion.Cut wsNew.Range("A1")
wsNew.Name = wsCurrent.Range("W2").Value
wsCurrent.Range("W2").Delete xlShiftUp
iLeft = iLeft - 1
Loop
wsCurrent.Range("W1").Clear
Application.ScreenUpdating = True
End Sub
BTW I don't intend to modify this for your specific file; this is something that you should do (or pay someone to do ;) ).
BTW It could be done using the normal (rather than Advanced) Filter. You would still copy the column and remove duplicates. This would have the benefit of not increasing the apparent size of the worksheet too much. But I decided to do it this way ;).
Added: Well, I felt inspired to achieve this with AutoFilter as well:
Sub SheetsFromAutoFilter()
Dim wsCurrent As Worksheet
Dim wsNew As Worksheet
Dim iLeft As Integer
Set wsCurrent = ActiveSheet
Application.ScreenUpdating = False
Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
iLeft = Range("W1").CurrentRegion.Rows.Count - 1
Do While iLeft > 0
Set wsNew = Worksheets.Add
With wsCurrent.Range("A5").CurrentRegion
.AutoFilter field:=7, _
Criteria1:=wsCurrent.Range("W1").Offset(iLeft).Value
.Copy wsNew.Range("A1")
.AutoFilter
End With
wsNew.Name = wsCurrent.Range("W1").Offset(iLeft).Value
iLeft = iLeft - 1
Loop
wsCurrent.Range("W1").CurrentRegion.Clear
Application.ScreenUpdating = True
End Sub
[Both procedures could be improved using Defined Names and some error handling/checking.]
if you want you can build a new collection which will have an array of only unique values and then loop over them. you will know that each
I know it's late and you've already selected an answer, but I'm working on a similar project involving a pivot table and decided to do it this way:
'Here I'm Filtering a column of Week numbers to get rid of non-numbers
'From a pivot table
'I select sheet where my underlying pivot data is located and establish the range
'My data is in column 2 and it ends after "DSLastRow" Rows starting at Row 2
Sheets("DataSheet").Select
DSLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'I create and redim an array that is large enough to hold all of the data in the range
Dim FilterCriteria(): RedimFilterCriteria(1 To DSLastRow)
For r = 2 To DSLastRow 'r for row / my data has a header in row 1
If Cells(r, 2).Value <> "" Then 'again, starting in column B (2)
'Check if it's already in the FilterCriteria Array
For CheckFCA = 1 To r
'Jumps to next row if it finds a match
If FilterCriteria(CheckFCA) = Cells(r, 2).Value Then GoTo Nextr
'Saves the value and jumps to next row if it reaches an empty value in the array
If IsEmpty(FilterCriteria(CheckFCA)) Then
FilterCriteria(CheckFCA) = Cells(r, 2)
GoTo Nextr
End If
Next CheckFCA
End if
Nextr:
Next r
'At this point FilterCriteria() is filled with all of the unique values
'I'm filtering a pivot table which is why I created the unique array from
'the source data, but you should be able to just loop through the table
Sheets("Pivot").Select
ActiveSheet.PivotTables("ReportPivot").PivotFields("Week").ClearAllFilters
With ActiveSheet.PivotTables("ReportPivot").PivotFields("Week")
For FilterPivot = 1 To DSLastRow
'I'm filtering out all non-numeric items
If IsEmpty(FilterCriteria(FilterPivot)) Then Exit For
If Not IsNumeric(FilterCriteria(FilterPivot)) Then
.PivotItems(FilterCriteria(FilterPivot)).Visible = False
End If
Next FilterPivot
End With
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