I have a reference file for a dashboard I am making. I want to be able to count the unique org names in a reference file column and make that number the amount of column headers in my separate dashboard. I used macro recorder to make it unique, but I am unsure of how to translate this into making a dynamic number of columns for my dashboard based on the count of unique org names in the ref file. Here's a picture attachment example of what the reference file could look like. So, if it counts that there are 5 unique names, I would like the separate dashboard to make 5 columns with those names as headers in each column.
Sub Macro1()
' Macro1 Macro
Columns("F:F").Select
Range("F1:F10000000000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns _
("O:O"), Unique:=True
ActiveCell.FormulaR1C1 = "=ROWS(R[-11]C:R[-2]C)"
End Sub
Here's a way to do it by loading the unique results into an array. This assumes the column headers go into A1.
Sub Macro1()
Dim wsRef As Worksheet
Dim wsDB As Worksheet
Set wsRef = Worksheets("reference")
Set wsDB = Worksheets("Dashboard")
With wsRef
.Range("C1:C9").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("F1"), Unique:=True
Dim arrValues As Variant
arrValues = .Range("F2", .Range("F" & .Rows.Count).End(xlUp))
End With
With wsDB
.Range(.Range("A1"), .Cells(1, UBound(arrValues))).Value = Application.WorksheetFunction.Transpose(arrValues)
End With
End Sub
Use a Dictionary object to get your unique values, then loop through the dictionary items to make your column headers. eg,
myCol = 1
For Each item in oDic.items
'Presuming you want your headers to start at A1
Cells(1, myCol).Value = item
myCol = myCol + 1
Next
Related
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
I am writing a script where I want to enable a search in a Database, presenting the results of the search queries in a different worksheet (which I have named Results), so that users do not have access to the whole database at the same time.
In order to do this I want to copy values from the "Database" worksheet into the "Results" worksheet. I have succeeded in selecting the right data from the "Database", in respect to any specific search criteria. I did this with the following code:
With Sheets("Database")
.Range(.Cells(i, 1), .Cells(i, 9)).Copy
End With
Now I want to paste the results into the "Results" spreadsheet and I have done so by writing the following:
Sheets("Results").Range("B600").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
By doing this, I don't quite understand:
if I have strictly defined the paste range as between the first empty row and B600 or;
if I am just defining the beginning of the paste range and, in the case that the search results exceed the 600th row, they will still be pasted after this row.
I ask this because, as the database grows, I will certainly need to guarantee a paste range greater than B600.
I have researched on it but cannot seem to be absolutely sure of what I have done exactly. I must say that I know that the first empty row in the "Results" database will always be 12. In this case, I know that I basically want to paste the search results from the 12th row on. Maybe there is a more straight-forward way to do this.
This is the entire code, for reference:
Private Sub SearchButton_Click()
'This is the search function
'1. declare variables
'2. clear old search results
'3. Find records that match criteria and paste them
Dim country As String
Dim Category As String
Dim Subcategory As String
Dim finalrow As Integer
Dim i As Integer 'row counter
'Erase any entries from the Results sheet
Sheets("Results").Range("B10:J200000").ClearContents
'Deformat any tables in the Results sheet
For Each tbl In Sheets("Results").ListObjects
tbl.Clear
Next
'Define the user-inputed variables
country = Sheets("Results").Range("D5").Value
Category = Sheets("Results").Range("D6").Value
Subcategory = Sheets("Results").Range("D7").Value
finalrow = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row
'If statement for search
'For every variable i, start comparing from row 2 until the final row
For i = 2 To finalrow
'If the country field is left empty
If country = "" Then
Sheets("Results").Range("B10:J200000").Clear
MsgBox "You must select a country in order to search the database. Please do so in the drop-down list provided."
Sheets("Results").Range("D5").ClearContents
Sheets("Results").Range("D6").ClearContents
Sheets("Results").Range("D7").ClearContents
Exit Sub
'If the country field is filled in and there results from the search made
ElseIf Sheets("Database").Cells(i, 1) = country And _
(Sheets("Database").Cells(i, 3) = Category Or Category = "") And _
(Sheets("Database").Cells(i, 4) = Subcategory Or Subcategory = "") Then
'Copy the headers of the table
With Sheets("Database")
.Range("A1:I1").Copy
End With
Sheets("Results").Range("B10:J10").PasteSpecial
'Copy the rows of the table that match the search query
With Sheets("Database")
.Range(.Cells(i, 1), .Cells(i, 9)).Copy
End With
Sheets("Results").Range("B600").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
'Hides search form
Me.Hide
End If
Next i
'Toggle Results sheet
Sheets("Results").Activate
'Format results as a table
Set rng = Range(Range("B10"), Range("B10").End(xlUp).SpecialCells(xlLastCell))
Set table = Sheets("Results").ListObjects.Add(xlSrcRange, rng, , xlYes)
table.TableStyle = "TableStyleMedium13"
Range("B11").Select
'Make Excel window visible
Application.Visible = True
End Sub
Thank you very much for your help.
You can count from the bottom of the sheet upto the last used cell in column B, and then OFFSET by 1 row. This prevents you needing to worry about
a) that the range to paste to starts from row 12 (they should contain values), and
b) that you are currently using a hard-coded 'anchor' of B600 which will need updating as the data grows.
Sample code:
Dim ws As Worksheet
Dim rngColumnBUsed As Range
Dim lngFirstEmptyRow As Long
Set ws = ThisWorkbook.Sheets("Results")
Set rngColumnBUsed = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0)
lngFirstEmptyRow = rngColumnBUsed.Row
Two ListObjects tblDatabase and tblResults
tblResults data gets cleared
A filter is applied to the second, third and fourth columns of tblDatabase
If there are less than 588 results, we copy the filtered records from tblDatabase to tblResults
If there are more than 588 results then we resize the filtered records' range down to the first 588 records and then copy them to tblResults
We never worry about formatting because tblResults keeps it's original format.
Sub ListObjectDemo()
Dim tblDatabase As ListObject, tblResults As ListObject
Set tblDatabase = Worksheets("Database").ListObjects("tblDatabase")
Set tblResults = Worksheets("Results").ListObjects("tblResults")
If Not tblResults.DataBodyRange Is Nothing Then tblResults.DataBodyRange.ClearContents
With tblDatabase.Range
.AutoFilter Field:=2, Criteria1:="Test A"
.AutoFilter Field:=3, Criteria1:="East"
.AutoFilter Field:=4, Criteria1:="Algeria"
End With
With tblDatabase.DataBodyRange
If .Rows.Count <= 588 Then
.Copy tblResults.ListRows.Add.Range
Else
.Resize(588).Copy tblResults.ListRows.Add.Range
End If
End With
End Sub
Dim searchdata as range, inputfromuser as string
inputfromuser = inputbox("type what you wanna search")
set searchdata = sheets("Database").find(inputfromuser).select
searchdata = activecell.value or activecell.offset(10,5).value
sheets("results").activate
with sheets("result")
range("a12",range("a12").end(xldown)).offset(1,0).select
searchdata.copy destination:= activecell
activecell.offset(1,0).select
end with
Not sure, if I understood you corectly mate.
I dont haveexcel sheet or VBE editor. Just wrote this directly on website. Pls amend as per your need.
I am having some difficulty with (vba lookup) issue.
I Have a sheet (sheet3) which has multiple rows of data of different invoices (each row of data includes the invoice number it relates to)Data sheet
I have copied the unique invoice numbers into separate sheets, each invoice has its own sheet and the invoice number is in cell B1.invoice sheet
What I want to do is to copy all rows from the data sheet to the sheet with the matching invoice number.
all I have for my current code is this which My separate invoice pages link of rather than using Vba to create them as there will be various other formatting and Formulrs on the page so im pretty much starting from scratch on my issue!
Private Sub CommandButton1_Click()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("sheet3")
Set s2 = Sheets("Bill Date")
s1.Range("F:G").Copy s2.Range("A:B")
s2.Range("A:B").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Your help will be appreciated
Thanks
In your VBA Macro, do this within a for loop:
Sub copyData()
Dim invNo As String
Dim lastRow As Integer
Dim sourceSht As Worksheet
Dim targSht As Worksheet
Set sourceSht = Worksheets("Sheet3")
'evaluates every data item from row 2 to last populated row
For Row = 2 To sourceSht.Cells(sourceSht.Rows.Count, 1).End(xlUp).Row
invNo = sourceSht.Range("F" & Row).Value
'if invNo blank, skip
If invNo <> "" Then
'try to find the sheet, make if does not exist
invNo = invNo & "_INV"
On Error Resume Next
Set targSht = Worksheets(invNo)
If targSht Is Nothing Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = invNo
Set targSht = Worksheets(invNo)
'SetHeader
End If
'find first empty row in targSht
lastRow = targSht.Cells(targSht.Rows.Count, 1).End(xlUp).Row + 1
'copy row of data
sourceSht.Range("A" & Row & ":L" & Row).Copy
targSht.Range("A" & lastRow & ":L" & lastRow).Select
targSht.Paste
'must do to make more sheets
Set targSht = Nothing
End If
Next
End Sub
I changed some of your specifications in favor of a simpler approach. I assumed the twelve columns you showed me are all you have. I added "_INV" to the end of the invoice sheets because purely numeric sheet names can cause errors. I am also pasting the row of data into the new sheet verbatim. If you keep your current header, you will need to change the order. You may consider changing your targSht header to make it easier. SetHeader is a placeholder for a block of code that sets up the header row in targSht however you want. Please mark correct if this solves your issue.
Demo (without invoice header):
I need a VBA macro that does the below:
This part works fine, I want it to make a new column on sheet1 and name it header name then color it.
Columns("P:P").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("P1").Select
ActiveCell.FormulaR1C1 = "Header Name"
Range("P1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
This part however I would like to look for the header name on sheet2 not just the column C (since sometimes the column locations can change)
Range("P2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[8],Sheet2!C[-15]:C[-14],2,FALSE)"
Range("P2").Select
Selection.AutoFill Destination:=Range("P2:P" & Cells(Rows.Count, "X").End(xlUp).Row)
so basically this is what I want it to do:
on sheet 1 make a new column in P and name it "header name" then I want it to do a vlook up for column x (header 2) on sheet 1 (by name if able) and compare it to sheet2 column a (header 02) and give me the matching information in column B (header 3)
I have used this vlookup =VLOOKUP(X2,Sheet2!A:B,2,FALSE) but I want them to be header names not x,a,b and to search the entire sheet to find the header names.
Column X name: Header 2
Column A name: Header 02
Column B name: Header 3
Column P name: Header Name
Hmm, somehow feels hard to give this away, this is my precious baby for doing the job.
But all I can do is thank stack overflow and all of the community for all they have done, so here goes:
NOTE! I use Dictionaries. To make Dictionaries work, in VBA editor goto Tools > References. In the pop up scroll down to "Microsoft Scripting Runtime" and check the box and click OK.
Option Base 1
Sub TransferData()
Dim Data() As Variant
Dim dataSheet As String
Dim resultSheet As String
Dim headingIndexes As New Dictionary
dataSheet = "Data"
dataStartCell = "A1"
resultSheet = "Result"
Data() = Sheets(dataSheet).Range(dataStartCell).CurrentRegion.Value
Call GetHeadingIndexes(Data(), headingIndexes)
Call Transfer(Data(), headingIndexes, resultSheet)
End Sub
Sub GetHeadingIndexes(ByRef Data() As Variant, ByRef headingIndexes As Dictionary)
'Creates a dictionary with key-value pairs
'
'Creates a dictionary structure with key-value pairs resembling a table:
' [Column Heading] | [Column Index]
' "Actual/Forecast" | 1
' "Brand" | 2
' "Division/ Line of Business" | 3
'
'Now it is easy and quick to find the column index based on column heading.
Dim i As Integer
For i = 1 To UBound(Data(), 2)
headingIndexes.Add Data(1, i), i 'Make key-value pairs out of column heading and column index
Next i
End Sub
Sub Transfer(ByRef Data() As Variant, ByRef headingIndexes As Dictionary, resultSheet As String)
Application.ScreenUpdating = False
Dim resultColumnHeading As String
Dim resultSheetColumnNumber As Integer
Dim dataColumnNumber As Integer
Dim row As Integer
'Loop through columns in result sheet. Assumes you have 16 columns
For resultSheetColumnNumber = 1 To 16
'Find the correct column in Data()
resultColumnHeading = resultSheet.Cells(1, resultSheetColumnNumber)
dataColumnNumber = headingIndexes(resultColumnHeading)
For row = 2 To UBound(Data(), 1)
'Transfer data from Data() array to the cell in resultSheet
'Note, referencing each cell like this is really slow, it is better to create a resultArray similar to the data array (called Data() in this example). However, explaining all the nuances would take a one hour phone call, and gets far from the question at hand)
resultSheet.Cells(row, resultSheetColumnNumber) = Data(row, dataColumnNumber)
Next row
Next resultSheetColumnNumber
Application.ScreenUpdating = True
End Sub
It might work if you change this:
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[8],Sheet2!C[-15]:C[-14],2,FALSE)"
to:
ActiveCell.Formula = "=vlookup(X" & ActiveCell.row & ",Sheet2!A:B,2,0)"
But that being said, be careful with ActiveCell and .Select. You may want to check out How to Avoid Using Select in VBA Macros
EDIT:
I've amended/added to the code to take into consideration your need for flexibility with regards to where the columns of data are located.
Sub test3()
'use the Header2sheet1column variable to hold the column number that "Header 2" is found in on sheet 1
Dim Header2sheet1column As Long
'search for "Header 2" across row 1 of sheet1 and remember the column number
Header2sheet1column = Application.Match("Header 2", ThisWorkbook.Sheets("Sheet1").Range("$1:$1"), 0)
'use the Header2sheet2column variable to hold the column number that "Header 2" is found in on sheet 2
Dim Header2sheet2column As Long
'search for "Header 2" across row 1 of sheet2 and remember the column number
Header2sheet2column = Application.Match("Header 2", ThisWorkbook.Sheets("Sheet2").Range("$1:$1"), 0)
'use the lookuprange variable to hold the range on sheet2 that will be used in the vlookup formula
Dim lookuprange As Range
'using With just so I don't have to type ThisWorkbook.Sheets("Sheet2") a bajillion times in the next couple lines
With ThisWorkbook.Sheets("Sheet2")
'set lookuprange variable - will start at column that "Header 2" is found on sheet 2 and will go to last row/column of the sheet
'having extra columns at the end of your vlookup formula isn't going to hurt. the
Set lookuprange = .Range(.Cells(1, Header2sheet2column), .Cells(.Rows.Count, .Columns.Count))
'put formula into Cell P2 on sheet1
ThisWorkbook.Sheets("Sheet1").Range("P2").Formula = "=vlookup(" & ThisWorkbook.Sheets("Sheet1").Cells(2, Header2sheet1column).Address(RowAbsolute:=False) & ",Sheet2!" _
& lookuprange.Address & "," _
& Header2sheet2column & ",0)"
End With
'using With again just so I don't have to type ThisWorkbook.Sheets("Sheet1") a bajillion times in the next couple lines
With ThisWorkbook.Sheets("Sheet1")
'fill formula in column P down to the row that the column
.Range("P2").AutoFill Destination:=.Range("P2:P" & .Cells(.Rows.Count, Header2sheet1column).End(xlUp).Row)
End With
End Sub
You'd be better off using named ranges that are created using the headers for each column. Then your vlookup could just refer to the names rather than the cell references.
To get an idea how to do this start recording a macro then choose your columns and Insert - Names - Create. You can adapt the macro to recreate the names every time your spreadsheet changes. The vlookups won't need to be changed because they will point to the named ranges wherever they are.
I'm far from a VBA expert. Two things in VBA plagued me for a long time until recently.
"Number Stored as Text" error
Find column by first row 'Name' not 'Column Letter'
I use this in a macro to copy & reorder columns in a new sheet:
Sub ColumnReorder()
'**********************************************************
'Paste this macro into the Workbook of each new "Employee_List_Weekly_Update"
'Functionality:
'1. Column order in the "Employee_List_Weekly_Update" worksheet changes fairly often.
' The macro will find each column by header name,
' select that column and copy it to the new sheet.
'2. The macro also converts "Employee ID#" to a number,
' removing the "Number saved as Text" error.
'**********************************************************
'Create new sheet
Sheets.Add.Name = "Roster_Columns_Reordered"
'Repeat for each column or range - For each new section change Dim letter
'Find Column in "Employee_List_Weekly_Update" - Copy it - Paste it in "Roster_Columns_Reordered" - Employee ID#
Dim a As Integer
Sheets("Employee_List_Weekly_Update").Select
Set rngData = Range("A1").CurrentRegion
a = Application.WorksheetFunction.Match("Employee ID#", Range("A1:BB1"), 0)
Columns(a).Select
Selection.Copy
Sheets("Roster_Columns_Reordered").Select
Range("A1").Select
ActiveSheet.Paste
'Use TextToColumns to convert "Number Stored as Text "
Selection.TextToColumns _
Destination:=Range("A:A"), _
DataType:=xlDelimited
'Find Column in "Employee_List_Weekly_Update" - Copy it - Paste it in "Roster_Columns_Reordered" - Name
Dim b As Integer
Sheets("Employee_List_Weekly_Update").Select
Set rngData = Range("A1").CurrentRegion
b = Application.WorksheetFunction.Match("Name", Range("A1:BB1"), 0)
Columns(b).Select
Selection.Copy
Sheets("Roster_Columns_Reordered").Select
Range("B1").Select
ActiveSheet.Paste
'Go to "Roster_Columns_Reordered" - Add AutoFilter - Freeze Top Row
Rows("1:1").Select
Selection.AutoFilter
With ActiveWindow
.SplitColumn = 2
.SplitRow = 1
End With
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
End Sub
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