[color=blue]Option[/color] [color=blue]Explicit[/color]
[color=lightgreen]'[/color]
[color=blue]Sub[/color] parse_Wind_AlanJuli2015()
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color], lr [color=blue]As[/color] Long: lr = wks1.Cells(Rows.Count, 1).End(xlUp).Row
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] [color=blue]Long[/color], lshtc [color=blue]As[/color] Long: lshtc = wks1.Columns.Count
[color=blue]Dim[/color] clmsOut [color=blue]As[/color] Range, Dataclm1 [color=blue]As[/color] Range, Heading [color=blue]As[/color] [color=blue]String[/color], nr [color=blue]As[/color] [color=blue]Long[/color]
[color=lightgreen]'--------------------------------------[/color]
[color=lightgreen]'Referrencing Ranges: Determine Columns, Ranges, Headings Required[/color]
vLkUpc = 4 [color=lightgreen]'CHANGE THE LOOK UP COLUMN NUMBER AS PER YOUR NEED[/color]
[color=blue]Dim[/color] rngTitle [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitle = wks1.Range("A1:F1") [color=lightgreen]'CHANGE THE TITLE ROW AS PER YOUR NEED[/color]
[color=blue]Set[/color] clmsOut = Application.Union(wks1.Columns(2), wks1.Columns(1)) [color=lightgreen]'CHANGE TO COLUMNS YOU WANT COPIED[/color]
[color=blue]Set[/color] Dataclm1 = Intersect(wks1.Columns(rngTitle.Column), wks1.Rows("" & rngTitle.Row & ":" & lr & ""))
Heading = Application.Intersect(rngTitle, wks1.Columns(vLkUpc)).Value
nr = wks1.Cells.Find(What:="" & Heading & "", After:=wks1.Cells(lr, vLkUpc), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
[color=lightgreen]'End of determining Required referrence ranges[/color]
[color=lightgreen]'make an Array for Unique Search values, based only on new data, using a Tempory column[/color]
wks1.Cells(1, lshtc) = Heading
[color=blue]For[/color] rws = nr [color=blue]To[/color] lr
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color]
[color=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = -1234 [color=blue]Then[/color]
wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc)
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color] rws
[color=blue]Dim[/color] myarr() [color=blue]As[/color] Variant: myarr() = Application.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants).Value)
wks1.Columns(lshtc).Delete
[color=lightgreen]'End of making an Array----------------------------------------[/color]
[color=lightgreen]'Make a New worksheet if necerssary, copy data to new or already there sheets[/color]
[color=blue]Dim[/color] ld [color=blue]As[/color] [color=blue]Long[/color], rngCopy [color=blue]As[/color] Range
[color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr)
rngTitle.AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & ""
[color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then
ld = 1: Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & ""
[color=blue]Else[/color]
Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count)
ld = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row + 1
End [color=blue]If[/color]
[color=lightgreen]'Copy to sheet[/color]
[color=blue]Set[/color] rngCopy = Intersect(wks1.Rows("" & nr - 1 & ":" & lr & ""), clmsOut) '
rngCopy.SpecialCells(xlCellTypeVisible).Copy Worksheets("" & myarr(rws) & "").Range("A" & ld & "")
[color=blue]Next[/color] rws
[color=lightgreen]'[color=blue]End[/color] making (if necerssary) new sheet and copying filtered rows to it[/color]
wks1.AutoFilterMode = [color=blue]False[/color]
rngTitle.Copy Intersect(wks1.Columns(rngTitle.Column), wks1.Rows("" & lr + 1 & ""))
End [color=blue]Sub[/color] [color=lightgreen]'Alan Passing Wind[/color]
[color=lightgreen]'[/color]
'
'
'
'
'
[color=lightgreen]'[/color]
'
'
'
[color=lightgreen]'[/color]
'
[color=blue]Sub[/color] parse_data_AlanJuli2015()
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet ( For first sheet : Set wks1 = ThisWorkbook.Worksheets(1) )[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]' turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Bound variable Row count used in looping '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here)[/color]
[color=blue]Dim[/color] lr [color=blue]As[/color] Long: [color=blue]Let[/color] lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
[color=blue]Dim[/color] lshtc [color=blue]As[/color] Long: [color=blue]Let[/color] lshtc = wks1.Columns.Count [color=lightgreen]'Number of Columns in sheet. Used for tempory Unique Range. Good idea to set to last column as this will not upset the determination of last column based on a Range.End(xltoleft) Property[/color]
[color=lightgreen]'--------------------------------------[/color]
[color=lightgreen]'Referrencing Ranges: Determine Columns, Ranges, Headings Required[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] Long: [color=blue]Let[/color] vLkUpc = 4 [color=lightgreen]'CHANGE THE LOOK UP COLUMN NUMBER AS PER YOUR NEED 'Column where search criteria for filtering is.[/color]
[color=blue]Dim[/color] rngTitle [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitle = wks1.Range("A1:F1") [color=lightgreen]'CHANGE THE HEADING ROW AS PER YOUR NEED[/color]
[color=blue]Dim[/color] sr [color=blue]As[/color] Long: [color=blue]Let[/color] sr = rngTitle.Row [color=lightgreen]'Initially sr is Upper Heading row[/color]
[color=blue]Dim[/color] sc [color=blue]As[/color] Long: [color=blue]Let[/color] sc = rngTitle.Column [color=lightgreen]'Left most column of Heading Row[/color]
[color=blue]Dim[/color] clmsOut [color=blue]As[/color] Range: [color=blue]Set[/color] clmsOut = Application.Union(wks1.Columns(2), wks1.Columns(1)) [color=lightgreen]'CHANGE TO COLUMNS YOU WANT COPIED[/color]
[color=blue]Dim[/color] rngTitleOut [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitleOut = Application.Intersect(rngTitle, clmsOut) [color=lightgreen]'Creat new range by slices of Initial Full Title range[/color]
[color=blue]Dim[/color] lc [color=blue]As[/color] Long: [color=blue]Let[/color] lc = wks1.Cells(sr, lshtc).End(xlToLeft).Column [color=lightgreen]'Last column with entry in heading in Sheet 1. Found by starting at last cell in row 1, then going backwards (ToLeft) until something is found, with .End returning a range from which the column property can be used to get the column number[/color]
[color=blue]Dim[/color] Dataclm1 [color=blue]As[/color] Range: [color=blue]Set[/color] Dataclm1 = Intersect(wks1.Columns(sc), wks1.Rows("" & sr & ":" & lr & "")) [color=lightgreen]'Returns the Left most column of data[/color]
[color=blue]Dim[/color] Heading [color=blue]As[/color] String: [color=blue]Let[/color] Heading = Application.Intersect(rngTitle, wks1.Columns(vLkUpc)).Value [color=lightgreen]'This is the heading in the Look Up Column, coming from the Value in the intersect of the Look Up Column and the Title Range Row[/color]
Dim nr [color=blue]As[/color] Long: [color=blue]Let[/color] nr = wks1.Cells.Find(What:="" & Heading & "", After:=wks1.Cells(lr, vLkUpc), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 [color=lightgreen]'Detertmine start of New Data. Start at cell in arbritrary column, then go backwards and when heading found, get row +1 for start of new data[/color]
[color=lightgreen]'End of determining Required referrence ranges[/color]
[color=lightgreen]' 'Optional Start Bit to Delete Sheets / Tabs------------[/color]
[color=lightgreen]' Application.DisplayAlerts = False 'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=lightgreen]' [color=blue]Dim[/color] ws As Worksheet 'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=lightgreen]' For Each ws In ActiveWorkbook.Worksheets 'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=lightgreen]' If ws.Name <> "ASheetToKeep" And ws.Name <> "Data" And ws.Name <> wks1.Name And ws.Name <> "AR Report" And ws.Name <> "101206" Then 'Name property here returns name without .xlsm bit on end[/color]
[color=lightgreen]' ws.Delete[/color]
[color=lightgreen]' Else 'Presumably then the worksheet name is That of the first sheet so[/color]
[color=lightgreen]' ' do nothing (Don't delete it!)[/color]
[color=lightgreen]' End If[/color]
[color=lightgreen]' Next ws[/color]
[color=lightgreen]' Application.DisplayAlerts = True 'Turn it back on[/color]
[color=lightgreen]' 'End Bit to delete any Sheets / Tabs------------[/color]
[color=lightgreen]'make an Array for Unique Search values, based only on new data, using a Tempory column[/color]
[color=blue]Let[/color] wks1.Cells(1, lshtc) = Heading [color=lightgreen]'The last Column inn the sheet is used. (This has an advantage of not interfering with our Method for getting lc). We give the array, that is to say the tempory column, a heading. Chosing the heading of the lookUpColumn is a neat trick : myarr will only ( uniquely ) stor it once at the top, and this will be neglected in the looping for sheet namnes[/color]
[color=blue]For[/color] rws = nr [color=blue]To[/color] lr [color=blue]Step[/color] 1 [color=lightgreen]'Going down all rows from just after heading in First sheet[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'Necersary to ensure carry on after error line if the match row cannot be determined, if below it is not there yet[/color]
[color=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = -1234 [color=blue]Then[/color] [color=lightgreen]'provided something is there, we check to see if that value is already in our vLook Up Array by looking to see for a match row. If it is there ( but not at a row of -1234 ! - a valid long number, but position that will never be found, ) we go to else.....[/color]
wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=lightgreen]'.....we come here if match errored, so it was not to be found, so we put it there ![/color]
[color=blue]Else[/color] [color=lightgreen]'Else do nothing - we had a match position. Redundant Code[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color] rws
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] 0 [color=lightgreen]'Disable the above Error handler[/color]
[color=blue]On[/color] Error [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Enable the default error handler for unpredictable errors[/color]
Dim myarr() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Array for Unique search criteria. Important to get this [color=blue]Dim[/color]ensioning right. Variant must be used as below initially an object is seen...>> http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants).Value) [color=lightgreen]'just a complicated but nice one-liner way of getting just the values and no empty cells in the Array. XlcellTypeConstants just gives constants, the second argument is the type. Here Strings (xlTextValues) would be there as the heading made sure of that - here excel guessed based on that due to the heading string "Unique".. This could be an untypical case where that second argument could be left out. Transpose is just to get the Array as A Row of Columns which we need rather than a Column of rows as is in the tempory Column.[/color]
wks1.Columns(lshtc).Delete [color=lightgreen]'Delete the tempory Column (Delete is usually better than Clear.. >> http://www.mrexcel.com/forum/excel-questions/787428-clear-delete-shift-%3Dxlup-let-y-%3D-y-%96-1-usedrange-rows-count-anomale.html[/color]
[color=lightgreen]'End of making an Array----------------------------------------[/color]
[color=lightgreen]'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
Dim ld [color=blue]As[/color] [color=blue]Long[/color], rngCopy [color=blue]As[/color] Range [color=lightgreen]'Variable for last data entry in sheet, modified range to be copied from first sheet based on COLUMNS wanted[/color]
[color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr) [color=lightgreen]'For each unique value in the Array'From 2 removes the heading.[/color]
wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=lightgreen]'This blends out everything except where rows meet our search citeria[/color]
[color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=lightgreen]'Check to see if the sheet is there by seeing if the reference to cell A1 in that sheet doesn#t exist. If it is true that it does not exist, then[/color]
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & "" [color=lightgreen]'Make it as that after the last sheet[/color]
rngTitleOut.Copy [color=lightgreen]'Headings range[/color]
Worksheets("" & myarr(rws) & "").Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
[color=blue]Else[/color]
Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=lightgreen]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=lightgreen]'.......->>---...Copy Entire rows or columns required of range that is visible (Not blended out) to the current sheet in loop (Note: by default ommiting .SpecialCells(xlCellTypeVisible) also works![/color]
[color=blue]Let[/color] ld = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row + 1 [color=lightgreen]'The Range Object last Cell in the sheet in column 1 has the property .End(with argument "looking Up" ) applied to return a new range ( cell) which is that of the last entry. To this cell the Property .Row is applied to give the row of that cell. +1 to get next row ( start of new data )[/color]
[color=blue]Set[/color] rngCopy = Intersect(wks1.Rows("" & nr & ":" & lr & ""), clmsOut) [color=lightgreen]'Returns Range object based on intersection of rows and columns needed: Rows are those of new data , columns are USER selected[/color]
[color=lightgreen]'Dataclm1.SpecialCells(xlCellTypeVisible).Range("A" & nr & ":C" & lr & "").Copy 'This will modify copied range to only the first three columns. It is only necerssary to have first column in initial range, but you can also access as many more columns as you like. Only the new data is copied by virtue of the use of nr[/color]
rngCopy.SpecialCells(xlCellTypeVisible).Copy [color=lightgreen]'This will copy the visible part, that is to say the filtered part of[/color]
Worksheets("" & myarr(rws) & "").Range("A" & ld & "").PasteSpecial Paste:=xlPasteValuesAndNumberFormats [color=lightgreen]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied[/color]
Sheets("" & myarr(rws) & "").Columns.AutoFit [color=lightgreen]'Just tidy up a bit[/color]
[color=blue]Next[/color] rws
[color=lightgreen]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
wks1.Activate [color=lightgreen]'Activate that sheet 1 just to see it[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 - turn off the AutoFilters[/color]
rngTitle.Copy [color=lightgreen]'Copy Headings, and then in next line paste at end of Current Data, by pasting at the range ( call) that is at the intersect from the first heading colin and the next empty row in data sheet[/color]
Application.Intersect(wks1.Columns(sc), wks1.Rows("" & lr + 1 & "")).PasteSpecial Paste:=xlPasteAllUsingSourceTheme [color=lightgreen]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied[/color]
TheEnd: [color=lightgreen]'Come Here for unexpected errors and do anything that should be done before ending program[/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 - turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color] [color=lightgreen]'Stops screen flicker after Copy Paste (clear the Clipboard.)[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'parse_data_AlanJuli2015[/color]
[color=lightgreen]'[/color]
'
[color=blue]Sub[/color] parse_data_AlanJuli2015HeadingCopyWithData()
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet ( For first sheet : Set wks1 = ThisWorkbook.Worksheets(1) )[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]' turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Bound variable Row count used in looping '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here)[/color]
[color=blue]Dim[/color] lr [color=blue]As[/color] Long: [color=blue]Let[/color] lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
[color=blue]Dim[/color] lshtc [color=blue]As[/color] Long: [color=blue]Let[/color] lshtc = wks1.Columns.Count [color=lightgreen]'Number of Columns in sheet. Used for tempory Unique Range. Good idea to set to last column as this will not upset the determination of last column based on a Range.End(xltoleft) Property[/color]
[color=lightgreen]'--------------------------------------[/color]
[color=lightgreen]'Referrencing Ranges: Determine Columns, Ranges, Headings Required[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] Long: [color=blue]Let[/color] vLkUpc = 4 [color=lightgreen]'CHANGE THE LOOK UP COLUMN NUMBER AS PER YOUR NEED 'Column where search criteria for filtering is.[/color]
[color=blue]Dim[/color] rngTitle [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitle = wks1.Range("A1:F1") [color=lightgreen]'CHANGE THE TITLE ROW AS PER YOUR NEED[/color]
[color=blue]Dim[/color] sr [color=blue]As[/color] Long: [color=blue]Let[/color] sr = rngTitle.Row [color=lightgreen]'Initially sr is Upper Heading row[/color]
[color=blue]Dim[/color] sc [color=blue]As[/color] Long: [color=blue]Let[/color] sc = rngTitle.Column
Dim clmsOut [color=blue]As[/color] Range: [color=blue]Set[/color] clmsOut = Application.Union(wks1.Columns(2), wks1.Columns(1)) [color=lightgreen]'CHANGE TO COLUMNS YOU WANT COPIED[/color]
[color=lightgreen]'[color=blue]Dim[/color] rngTitleOut As Range: Set rngTitleOut = Application.Intersect(rngTitle, clmsOut) 'Creat new range by slices of Initial Full Title range[/color]
[color=blue]Dim[/color] lc [color=blue]As[/color] Long: [color=blue]Let[/color] lc = wks1.Cells(sr, lshtc).End(xlToLeft).Column [color=lightgreen]'Last column with entry in heading in Sheet 1. Found by starting at last cell in row 1, then going backwards (ToLeft) until something is found, with .End returning a range from which the column property can be used to get the column number[/color]
[color=blue]Dim[/color] Dataclm1 [color=blue]As[/color] Range: [color=blue]Set[/color] Dataclm1 = Intersect(wks1.Columns(sc), wks1.Rows("" & sr & ":" & lr & ""))
[color=blue]Dim[/color] Heading [color=blue]As[/color] String: [color=blue]Let[/color] Heading = Application.Intersect(rngTitle, wks1.Columns(vLkUpc)).Value [color=lightgreen]'This is the heading in the Look Up Column, coming from the Value in the intersect of the Look Up Column and the Title Range Row[/color]
Dim nr [color=blue]As[/color] Long: [color=blue]Let[/color] nr = wks1.Cells.Find(What:="" & Heading & "", After:=wks1.Cells(lr, vLkUpc), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 [color=lightgreen]'Detertmine start of New Data. Start at cell in arbritrary column, then go backwards and when heading found, get row +1 for start of new data[/color]
[color=lightgreen]'End of determining Required referrence ranges[/color]
[color=lightgreen]' 'Optional Start Bit to Delete Sheets / Tabs------------[/color]
[color=lightgreen]' Application.DisplayAlerts = False 'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=lightgreen]' [color=blue]Dim[/color] ws As Worksheet 'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=lightgreen]' For Each ws In ActiveWorkbook.Worksheets 'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=lightgreen]' If ws.Name <> "ASheetToKeep" And ws.Name <> "Data" And ws.Name <> wks1.Name And ws.Name <> "AR Report" And ws.Name <> "101206" Then 'Name property here returns name without .xlsm bit on end[/color]
[color=lightgreen]' ws.Delete[/color]
[color=lightgreen]' Else 'Presumably then the worksheet name is That of the first sheet so[/color]
[color=lightgreen]' ' do nothing (Don't delete it!)[/color]
[color=lightgreen]' End If[/color]
[color=lightgreen]' Next ws[/color]
[color=lightgreen]' Application.DisplayAlerts = True 'Turn it back on[/color]
[color=lightgreen]' 'End Bit to delete any Sheets / Tabs------------[/color]
[color=lightgreen]'make an Array for Unique Search values, based only on new data, using a Tempory column[/color]
[color=blue]Let[/color] wks1.Cells(1, lshtc) = Heading [color=lightgreen]'The last Column inn the sheet is used. (This has an advantage of not interfering with our Method for getting lc). We give the array, that is to say the tempory column, a heading. Chosing the heading of the lookUpColumn is a neat trick : myarr will only ( uniquely ) stor it once at the top, and this will be neglected in the looping for sheet namnes[/color]
[color=blue]For[/color] rws = nr [color=blue]To[/color] lr [color=blue]Step[/color] 1 [color=lightgreen]'Going down all rows from just after heading in First sheet[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'Necersary to ensure the looping goes on if the match row cannot be determined if it is not there yet[/color]
[color=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = -1234 [color=blue]Then[/color] [color=lightgreen]'provided something is there, we check to see if that value is already in our vLook Up Array by looking to see for a match row. If it is there ( but not at a row of -1234 ! - a valid long number, but position that will never be found, ) we go to else.....[/color]
wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=lightgreen]'.....we come here if match errored, so it was not to be found, so we put it there ![/color]
[color=blue]Else[/color] [color=lightgreen]'Else do nothing - we had a match position. Redundant Code[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color] rws
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] 0 [color=lightgreen]'Disable the above Error handler now that we are finished using it[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Enable the default error handler for unpredictable errors[/color]
Dim myarr() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Array for Unique search criteria. Important to get this [color=blue]Dim[/color]ensioning right. Variant must be used as below initially an object is seen...>> http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants).Value) [color=lightgreen]'just a complicated but nice one-liner way of getting just the values and no empty cells in the Array. XlcellTypeConstants just gives constants, the second argument is the type. Here Strings (xlTextValues) would be there as the heading made sure of that - here excel guessed based on that due to the heading string "Unique".. This could be an untypical case where that second argument could be left out. Transpose is just to get the Array as A Row of Columns which we need rather than a Column of rows as is in the tempory Column.[/color]
wks1.Columns(lshtc).Delete [color=lightgreen]'Delete the tempory Column (Delete is usually better than Clear.. >> http://www.mrexcel.com/forum/excel-questions/787428-clear-delete-shift-%3Dxlup-let-y-%3D-y-%96-1-usedrange-rows-count-anomale.html[/color]
[color=lightgreen]'End of making an Array----------------------------------------[/color]
[color=lightgreen]'Make a New worksheet, if necerssary with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
Dim ld [color=blue]As[/color] [color=blue]Long[/color], rngCopy [color=blue]As[/color] Range [color=lightgreen]'Variable for last data entry in sheet, modified range to be copied from first sheet based on COLUMNS wanted[/color]
[color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr) [color=lightgreen]'For each unique value in the Array'From 2 removes the heading[/color]
wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=lightgreen]'This blends out everything except where rows meet our search citeria[/color]
[color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=lightgreen]'Check to see if the sheet is there by seeing if the reference to cell A1 in that sheet doesn#t exist. If it is true that it does not exist, then[/color]
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & "" [color=lightgreen]'Make it as that after the last sheet[/color]
Worksheets("" & myarr(rws) & "").Range("A2").Value = "-" [color=lightgreen]'bogdge to offset start[/color]
[color=blue]Else[/color]
Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=lightgreen]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=lightgreen]'.......->>---...Copy Entire rows or columns required of range that is visible (Not blended out) to the current sheet in loop (Note: by default ommiting .SpecialCells(xlCellTypeVisible) also works![/color]
[color=blue]Let[/color] ld = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row + 1 [color=lightgreen]'The Range Object last Cell in the sheet in column 1 has the property .End(with argument "looking Up" ) applied to return a new range ( cell) which is that of the last entry. To this cell the Property .Row is applied to give the row of that cell. +1 to get next row ( start of new data )[/color]
[color=blue]Set[/color] rngCopy = Intersect(wks1.Rows("" & nr - 1 & ":" & lr & ""), clmsOut) [color=lightgreen]'Returns Range object based on intersection of rows and columns needed: Rows are those of new data , columns are USER selected. - 1 will return the headings when visible, which only will include the initial Top Headings which are allways visible.[/color]
[color=lightgreen]'Dataclm1.SpecialCells(xlCellTypeVisible).Range("A" & nr & ":C" & lr & "").Copy 'This will modify copied range to only the first three columns. It is only necerssary to have first column in initial range, but you can also access as many more columns as you like. Only the new data is copied by virtue of the use of nr[/color]
rngCopy.SpecialCells(xlCellTypeVisible).Copy [color=lightgreen]'This will copy the visible part, that is to say the filtered part of[/color]
Worksheets("" & myarr(rws) & "").Range("A" & ld & "").PasteSpecial Paste:=xlPasteValuesAndNumberFormats [color=lightgreen]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied[/color]
Worksheets("" & myarr(rws) & "").Columns.AutoFit [color=lightgreen]'Just tidy up a bit[/color]
[color=blue]Next[/color] rws
[color=lightgreen]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
wks1.Activate [color=lightgreen]'Activate that sheet 1 just to see it[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 - turn off the AutoFilters[/color]
rngTitle.Copy [color=lightgreen]'Copy Headings, and then in next line paste at end of Current Data, by pasting at the range ( call) that is at the intersect from the first heading colin and the next empty row in data sheet[/color]
Application.Intersect(wks1.Columns(sc), wks1.Rows("" & lr + 1 & "")).PasteSpecial Paste:=xlPasteAllUsingSourceTheme [color=lightgreen]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied[/color]
TheEnd: [color=lightgreen]'Come Here for unexpected errors and do anything that should be done before ending program[/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 - turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color] [color=lightgreen]'Stops screen flicker after Copy Paste (clear the Clipboard.)[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'parse_data_AlanJuli2015HeadingCopyWithData[/color]
[color=lightgreen]'.........[/color]
'Einfügen Insert 01.02.2015 00:02 .Paste
[color=lightgreen]'Formeln Formula 42036.00197 .PasteSpecial Paste:=xlPasteFormulas[/color]
[color=lightgreen]'Werte Value 42036.00197 .PasteSpecial Paste:=xlPasteValues[/color]
[color=lightgreen]'Alles Everything 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteAll[/color]
[color=lightgreen]'Formate Format .PasteSpecial Paste:=xlPasteFormats[/color]
[color=lightgreen]'Formate, dann Werte Format, followed by value 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteValues[/color]
[color=lightgreen]'Alles mit Quelldesign Everything with source design 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteAllUsingSourceTheme[/color]
[color=lightgreen]'Alles außer Rahmen Everything except Borders 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteAllExceptBorders[/color]
[color=lightgreen]'Formeln und Zahlenwerte Formulas and number Format 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteFormulasAndNumberFormats[/color]
[color=lightgreen]'Werte und Zahlenwerte Value and Number Format 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteValuesAndNumberFormats[/color]
[color=lightgreen]'.......... seperate line needed for .PasteSpecial Paste:=xlPasteColumnWidths[/color]
[color=blue]Function[/color] UnionRanges(rOne [color=blue]As[/color] Excel.Range, rTwo [color=blue]As[/color] Excel.Range) [color=blue]As[/color] Excel.Range
[color=blue]If[/color] rOne [color=blue]Is[/color] [color=blue]Nothing[/color] [color=blue]Then[/color]
[color=blue]Set[/color] UnionRanges = rTwo
[color=blue]Else[/color]
[color=blue]Set[/color] UnionRanges = Application.Union(rOne, rTwo)
[color=blue]End[/color] [color=blue]If[/color]
End [color=blue]Function[/color]
