Here is my code :
Dim i As Integer, a As Integer, rowsInThere As Integer, rowsInI As Integer
Dim ws As Worksheet, b As Integer
Dim x As Integer, z As Integer
Dim total As Integer
Dim value As String
rowsInProjects = Sheets("Projects").UsedRange.Rows.Count
z = 3
Worksheets("Summary_Sheet (2)").Range("b5:b50").ClearContents
Worksheets("Summary_Sheet (2)").Range("c5:c50").ClearContents
Worksheets("Summary_Sheet (2)").Range("d5:d50").ClearContents
Worksheets("Summary_Sheet (2)").Range("e5:e50").ClearContents
Worksheets("Summary_Sheet (2)").Range("F5:F50").ClearContents
Worksheets("Summary_Sheet (2)").Range("G5:G50").ClearContents
Worksheets("Summary_Sheet (2)").Range("H5:H50").ClearContents
For a = 1 To rowsInProjects
value = Worksheets("Projects").Cells(a, 1).value
Worksheets("Summary_Sheet (2)").Cells(a + 4, 2).value = value
For i = 5 To Worksheets.Count
rowsInI = Worksheets(i).UsedRange.Rows.Count
For x = 1 To rowsInI
If Worksheets(i).Cells(x + 8, 3).value = value Then
total = total + Worksheets(i).Cells(x + 8, 6).value
End If
Worksheets("Summary_Sheet (2)").Cells(i, z).value = total
Next x
z = z + 1
Next i
z = 3
Next a
There error arises on the total = total + ... line. What my code is doing is copying a list of projects from a worksheet into a new one.
It then has to search through the other worksheets for each of the project names added. Each of the other worksheets will have 2-3 records with the project name. I want to get the total cost of the project from each worksheet and then insert it back into the orginal file.
Steps:
1. Create list of projects
Iterate through List
iterate through each worksheet
totaling values from matching projects
Insert value back into project list
J O'Brien, Choate and Townsend are the 3 worksheets
This is the Choate worksheet
Is this approach right for what I am trying to achieve?
you're probably overflowing the max size of an Integer, which is 32767. Try using a long for your range loop counter instead.
This would apply to a, x, z and rowsInI
You also asked if this (your method) was the right approach, Yours works so yes it is. However, it could possibly be optimised.
For every item in your project list, you're iterating over every row in your data sheet in all of your data sheets.
Which, depending on the number of rows in each sheet, is a fair few! (its at least Projects * Rows * 3)
I dont know if your "projects" list is one you generate per-run, so you only get a few projects or if its just everything you've got.
Hopefully the code below makes some sense, if you decide to give it a go please make sure you run it on a copy of your data! It's an example and it only dumps the result to the debug window.
The code below (which may not function perfectly as I might have got the columns and rows wrong) will loop over each sheet once and calculate a per-sheet total for each project (allowing for multiple instances of the same project in a single sheet, if this is possible in your data)
Sub Main()
Dim Projects As Object
'Dim Projects As Scripting.Dictionary
Set Projects = CreateObject("Scripting.Dictionary")
'Set Projects = New Scripting.Dictionary
Dim Project As String
Dim Sheets() As String
Dim Name As String
Dim Sheet As Worksheet
Dim SheetIndex As Integer
Dim ProjectColumn As Variant
Dim TotalColumn As Variant
Dim Index As Integer
Dim Max As Long
Dim MaxRow As Long
' You'll need to put your sheet names below
' not very nice, just a way to predefine an array containing sheet names
Sheets = Split("Sheet1,Sheet2,Sheet3", ",")
' loop over all the sheets
For SheetIndex = 0 To UBound(Sheets)
' get a reference to the sheet were looking at
Set Sheet = ThisWorkbook.Worksheets(Sheets(SheetIndex))
' calculate the last row in the workbook (as using UsedRange isnt always right)
MaxRow = Sheet.Cells(Sheet.Rows.Count, 3).End(xlUp).Row
' get the data were looking for
' the 9 in the next 2 lines might be wrong, it should be the row# for the first data row
Set ProjectColumn = Sheet.Range(Sheet.Cells(9, 3), Sheet.Cells(MaxRow, 3)) ' the 9 here might be wrong!
Set TotalColumn = Sheet.Range(Sheet.Cells(9, 6), Sheet.Cells(MaxRow, 6)) ' again, 9
Max = MaxRow - 8 ' adjust the max row to account for the +8 header cells above the data
For Index = 1 To Max
' loop over all the projects in the current sheet
Project = ProjectColumn(Index, 1)
' this allows for multiple instances of the same project per sheet (no idea if this occurs in your data)
If Projects.Exists(Project) Then
If Projects(Project).Exists(Sheets(SheetIndex)) Then
' update the total
Projects(Project)(Sheets(SheetIndex)) = Projects(Project)(Sheets(SheetIndex)) + TotalColumn(Index, 1)
Else
' inclue the total for the sheet
Projects(Project).Add Sheets(SheetIndex), CLng(TotalColumn(Index, 1))
End If
Else
' new project, add it and the total value for the current sheet
'Projects.Add Project, New Scripting.Dictionary
Projects.Add Project, CreateObject("Scripting.Dictionary")
Projects(Project).Add Sheets(SheetIndex), CLng(TotalColumn(Index, 1))
End If
Next Index
Set ProjectColumn = Nothing
Set TotalColumn = Nothing
Next SheetIndex
' Projects now contains a list of all projects, and the totals for your sheets.
' Projects
' - Project Name
' - - Sheet Name - Sheet Total
' dump the data to the immediate window in the vba editor
For Each Key In Projects.Keys
For Each SubKey In Projects(Key).Keys
Debug.Print Key & ", " & SubKey & " = " & Projects(Key)(SubKey)
Next SubKey
Next Key
End Sub
Using this you'd only need to iterate over each sheet once and then one further iteration over the projects sheet to extract the required totals from the result.
My normal approach is to hold all the available data in one worksheet so I can analyse it using pivot tables. If I then need to create a non-pivot table worksheet, I then use VBA to copy and PasteSpecial the pivot table as a regular range.
If there's a really good reason to hold this data in 3 separate worksheets, I would amalgamate the 3 sheets using VBA (basically copying and pasting all the data into a single worksheet with one set of column headers), adding an extra column that contains either "Choate", "OBrien" or "Townsend" during the copy/paste process, then creating a pivot table from the resulting amalgamation.
I use this approach a lot - all my data is standardised and I can filter the pivot table as required - by date, project, manager/salesperson/creator (Choate, Townsend and O'Brien), currency, or whatever.
I'm afraid this isn't strictly speaking an answer to your question, more a suggestion of a different approach. Of course, I don't know the circumstances of how you get this data, so it may not be feasible for you.
Related
Requesting some help from you more advanced excel VBA wizards.
Situation: I work as a medical administrator of sorts. HIPPA is obviously a concern for me as my personal tracker does contain a lot of HIPPA, and the whole "need to know" bit is a big deal. I need to have a workbook available for my subordinate staff to see without violating HIPPA
I have a workbook with a lot of data. I would like a separate workbook (Book2) to pull names from column A(the patients unit) and B(their name) if they meet a number or text condition from a separate column (let's call it column D).
I know I can filter, then copy/paste the list or data that is needed for them, but that is time consuming for 5 separate units with 100+ patients each. If at all possible, I would prefer to share Book2 with the option for them to leave comments next to the name. The idea is to just update BookA, so the can have the most up to date names in real time.
I've tried VBAs and customizing them to my criteria , but cant seem to find anything that works. Any help is appreciated.
*OP note - I'm still very much a novice at this whole macro thing. I'm not to the point of writing any code of my own yet, just stealing other people efforts. Which has been done successfully in previous needs.
The following code should get you started (Run from Book2);
Sub CopyIfCriteria()
'Get other workbook and worksheet
Dim wb As Workbook
Set wb = Excel.Workbooks("BookA.xlsx")
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
'Column 1 = A
Dim unit As Long
unit = 1
'Column 2 = B
Dim name As Long
name = 2
'Column 4 = D
Dim criteria As Long
criteria = 4
'Row 1 = 1, change if headers
Dim firstRow As Long
firstRow = 1
'Row n = last row with data
Dim lastRow As Long
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'Current row index on BookA, starts at first row
Dim copyIndex As Long
copyIndex = firstRow
'Current row index on Book2, starts at row 1
Dim pasteIndex As Long
pasteIndex = 1
For copyIndex = firstRow To lastRow
'Change what the condition is to check if criteria is correct
If (CBool(ws.Cells(copyIndex, criteria).Value) = True) Then
'Copy unit and name to the next available row on Book2; pasteIndex
ws.Cells(copyIndex, unit).Copy Cells(pasteIndex, unit)
ws.Cells(copyIndex, name).Copy Cells(pasteIndex, name)
'Use pasteIndex to find what row we're up to on Book2, increment everytime we use a row
pasteIndex = pasteIndex + 1
End If
Next copyIndex
End Sub
This will simply get the BookA workbook, assuming it is opened in Excel, and then iterate through every row. If column D (4) has the correct criteria, then it'll copy column 1 and 2 (A & B) of that row to the next un-used row in Book2.
You will ned to have a blank Excel file (from which the code is run) open, as well as having BookA open (and having the data on Sheet1) of BookA. If they're not in 'BookA.xlsx' or 'Sheet1' then simply change the names to suit your needs.
Do take the time to just read through it and take not of the comments to help you understand better how it is doing it.
Effectively what I am trying to accomplish is to filter a database (all in Sheet 1) by names, which are given in column A, and then perform various data analysis on the now filtered visible data, and then copy that data to a new sheet in a given cell.
For example, filter the data in Sheet 1 by the name 'Smith' in column A and then let's say sum all of the visible data in column B and print that to cell C3 on Sheet 2. The more advanced data analysis I am sure I can tackle on my own, just want to get rolling here and I am definitely new to VBA macro coding. I have created all of these databases using Python.
The last piece of this, would be being able to loop through all of the filter criteria in column A (which I will not know before-hand and may be anywhere from 10-20 names.
Here is the code I am working with (there are likely some syntax errors in here as well):
Option Explicit
Sub Data()
Dim playername As String
Dim team As String
Dim numFilters As Integer
Dim hits As Integer
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim copyRange As Range
Dim lastRow As Long
Dim i As Integer
team = ThisWorkbook.Sheets(1).Name
numFilters = ActiveSheet.AutoFilter.Filters.Count ' I want this to capture the num of filter criteria for column A
For i = 1 To numFilters
playername = Sheets(team).Filter(i) ' This would be the filter criteria for the given iteration
ActiveSheet.Range("$A$1:$AN$5000").AutoFilter field:=1, Criteria1:=playername
' Create new sheet with name of person
Sheets.Add After:=ActiveSheet
ActiveSheet.Select
ActiveSheet.Name = playername
Set tgt = ThisWorkbook.Sheets(i + 1)
' Perform data analysis (e.g. sum column B of filtered data)
src.AutoFilterMode = False
' Find the last row with data in column A
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' The range that we are auto-filtering (all columns)
Set filterRange = src.Range("A1:AN" & lastRow)
' Set the range to start in row 2 to prevent copying the header
Set copyRange = src.Range("B2:B" & lastRow)
' Copy the sum of column B to our target cell on the sheet corresponding to this iteration
Application.WorksheetFunction.Sum(copyRange.SpecialCells(xlCellTypeVisible)).Copy tgt.Range("A1")
Next i
End Sub
This is currently failing on the Application.WorksheetFunction.Sum line with the error 'Invalid qualifier'. Thanks for any help and please let me know if something needs clarified.
I'm a newbie to VBA/coding in general and my usual tactic of sticking bits of pre-written code isn't working for my problem.
I'm looking to create a macro that will do 3 things:
Allow me to find a starting point for the data in a column.
Start counting the number of rows once the cell value has
changed to a constant.
Once the value moves back to the starting point for the count to stop and record the number of cells counted in separate column with positioning of the count in that column at the start point of the count.
Repeat until the end of the data.
For this case the start point will be when the cell has a value of >0.
It will increase to a constant number (300).
Once at 300 the macro will have to count the number of rows that contain the numerical value 300 until the value goes back to 0.
Report count in a separate table on the worksheet with the entry being input at the same relative position in the new table as when the count started from the data.
And finally the loop.
I need to also do a similar count but in the horizontal direction (i.e. counting columns on a row). If anyone can create a code for the vertical/row count problem above I'd really appreciate it if you could annotate it so I can attempt to understand/learn which bits of code carry out each action and thus change it up for horizontal/column count.
I've attached a screenshot of the spreadsheet however as a new user it must be as a link. The blue highlighted table is the data used for the vertical /row count problem I am talking about. The blank table underneath the highlighted table has manually inputted correct answers for the first column of data for what I would like the macro to do in case I haven't accurately described my request.
I have also attached the horizontal table with correct manually inputted answers for row 1 in the separate table for the column count along the row.
Lastly, here is the code that I have written to tackle the problem, however it is very basic and won't run.
Sub Count0()
For Each c In Worksheets("Sheet1").Range("D30:D39")
If c.Value = 0 Then
End If
If c.Value > 0 Then
v = Range(c.Value)
For i = 3 To Rows.Count
If Cells(i, 1).Value <> v Then
MsgBox CStr(i - 2)
End If
Next i
Next c
End Sub
This worked in the limited case I tested (two columns and several rows in different patterns. It's pretty basic--there are more elegant ways to do it.
Sub Count0()
'To hold the current cell
Dim current As Range
'To hold the total number of rows and columns having data
Dim rows As Long
Dim cols As Long
'To iterate across rows and columns
Dim r As Long
Dim c As Long
'Flag/counter variables
Dim found As Long 'Saves row on which first "constant" was found
Dim count As Long 'Saves count of "contants"
'Use SpecialCells method to obtain the maximum number of rows and columns
' that have data.
cols = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Column
rows = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'Increment through all columns that have data. This is a bit inefficient
' because it really isn't necessary to go through all the empty cells,
' but it works.
For c = 1 To cols
'Initialize flag/counter
found = 0
count = 0
'Increment through all rows for the current column.
For r = 1 To rows
'Examine the current cell
Set current = Worksheets("Sheet1").Cells(r, c)
'For positive values, save the first row that has the value
' and count the number of values.
If current.Value > 0 Then
If found = 0 Then found = r
count = count + 1
End If
'When the next non-positive value is reached--OR the end of the
' row is reached--and there was a constant found, write the count
' to the next worksheet in the cell corresponding to the row and
' column having the first instance of the constant.
If (current.Value <= 0 Or r = rows) And found > 0 Then
Worksheets("Sheet2").Cells(found, c).Value = count
'Reset the flag/counter
found = 0
count = 0
End If
Next r
Next c
End Sub
I was struggling with what you had written, and ended up doing this in the end. I left you variables for changing the sheets to read from and print to (assuming you can print the results to another sheet- if not it should be easy enough to change).
This should also work for all cells in your range, assuming that there are values in all boxes.
Problems I noted with your original code were:
The first if did nothing
I'm pretty sure you shouldn't use numbers in sub/function names
Dimensioning no variables is a bad idea
Anyway, give me a comment if you need any help (and well done for writing a good first question).
Sub CountZero()
Dim SourceSheet As Worksheet, SummarySheet As Worksheet
Dim CurrentCell As Range
Dim FirstRow As Long, LastRow As Long
Dim FirstColumn As Long, LastColumn As Long
Dim TotalValues As Long
Set SourceSheet = Worksheets("Sheet1")
Set SummarySheet = Worksheets("Sheet2")
FirstRow = 1
LastRow = SourceSheet.Range("A" & rows.count).End(xlUp).row
FirstColumn = 1
LastColumn = SourceSheet.Cells(1, Columns.count).End(xlToLeft).column
For col = FirstColumn To LastColumn
For Rw = FirstRow To LastRow
Set CurrentCell = SourceSheet.Cells(Rw, col)
If CurrentCell <> 0 Then
TotalValues = ProcessSection(CurrentCell)
SummarySheet.Cells(Rw, col).value = TotalValues
Rw = Rw + TotalValues
End If
Next Rw
Next col
End Sub
Function ProcessSection(FirstCellWithValue As Range) As Long
Dim Counter As Long: Counter = 0
Do Until FirstCellWithValue.Offset(Counter, 0).value <> FirstCellWithValue.value
Counter = Counter + 1
Loop
ProcessSection = Counter
End Function
As a small disclaimer, I haven't tested this, let me know if there are problems.
I wrote a macro that compares the columns B, which contains file numbers, in two worksheets. There are three possibilities: the file number exists in both columns, the file number exists only in the first column and the file number exists only in the second column. If e.g. the file number exists in both columns, the macro should copy/paste the entire row to another sheet. Same for the other two scenario's.
My code work perfect for a small file (around 500 rows, 236 columns), but for the large files it doesn't work. It takes way too long, and at the end it just crashes. I already tried the usual tricks to speed up the macro.
Option Explicit
Sub CopyPasteWorksheets()
Dim wbDec As Workbook, wbJune As Workbook, wbAnalysis As Workbook
Dim wsDec As Worksheet, wsJune As Worksheet
Dim PresPres As Worksheet, PresAbs As Worksheet, AbsPres As Worksheet
'Stop screen from updating to speed things up
Application.ScreenUpdating = False
Application.EnableEvents = False
'Add 3 new worksheets. They each represent a different category, namely the one with already existing insurances, one with new insurances
'and one with the insurances that are closed due to mortality, lapse or maturity. Add two (temporary) worksheets to paste the databases.
Worksheets.Add().Name = "PresPres"
Worksheets.Add().Name = "PresAbs"
Worksheets.Add().Name = "AbsPres"
Worksheets.Add().Name = "DataDec"
Worksheets.Add().Name = "DataJune"
'Define the active workbook
Set wbAnalysis = ThisWorkbook
'Define the first database. Copy/paste the sheet and close them afterwards.
Set wbDec = Workbooks.Open(Filename:="F:\Risk_Management_2\Embedded_Value\2015\20151231\Data\DLL\Master Scala\Extract.xlsx")
wbDec.Sheets("SCALA").Range("A1").CurrentRegion.Copy
wbAnalysis.Sheets("DataDec").Range("A1").PasteSpecial xlPasteValues
wbDec.Close
'We have to do the same for the other database. We cannot do it at the same time, because both files have the same name,
'and can't be opened at the same time.
Set wbJune = Workbooks.Open(Filename:="F:\Risk_Management_2\Embedded_Value\2016\20160630\Data\DLL\Master Scala\extract.xlsx")
wbJune.Sheets("SCALA").Range("A1").CurrentRegion.Copy
wbAnalysis.Sheets("DataJune").Range("A1").PasteSpecial xlPasteValues
wbJune.Close
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub Compare()
Dim DataDec As Worksheet, DataJune As Worksheet
Dim lastRowDec As Long
Dim lastRowJune As Long
Dim lastRowPresAbs As Long
Dim lastRowPresPres As Long
Dim lastRowAbsPres As Long
Dim foundTrue As Boolean
Dim i As Long, j As Long, k As Long, l As Long
'Define the last row of the different sheets
lastRowDec = Sheets("DataDec").Cells(Sheets("DataDec").Rows.Count, "B").End(xlUp).Row
lastRowJune = Sheets("DataJune").Cells(Sheets ("DataJune").Rows.Count, "B").End(xlUp).Row
lastRowPresAbs = Sheets("PresAbs").Cells(Sheets("PresAbs").Rows.Count, "B").End(xlUp).Row
lastRowPresPres = Sheets("PresPres").Cells(Sheets ("PresPres").Rows.Count, "B").End(xlUp).Row
lastRowAbsPres = Sheets("AbsPres").Cells(Sheets("AbsPres").Rows.Count, "B").End(xlUp).Row
'Compare the file numbers in column B of both sheets. If they are the same, copy/paste the entire row to sheet PresPres,
'if they are not, copy/paste the entire row to sheet PresAbs.
For i = 1 To lastRowDec
foundTrue = False
For j = 1 To lastRowJune
If Sheets("DataDec").Cells(i, 1).Value = Sheets("DataJune").Cells(j, 1).Value Then
foundTrue = True
Sheets("PresPres").Rows(lastRowPresPres + 1) = Sheets("DataDec").Rows(i)
lastRowPresPres = lastRowPresPres + 1
Exit For
End If
Next j
If Not foundTrue Then
Sheets("DataDec").Rows(i).Copy Destination:= _
Sheets("PresAbs").Rows(lastRowPresAbs + 1)
lastRowPresAbs = lastRowPresAbs + 1
End If
Next i
'Look if there are file numbers that are only present in June's database. If so, copy/paste entire row to sheet AbsPres.
For k = 1 To lastRowJune
foundTrue = False
For l = 1 To lastRowDec
If Sheets("DataJune").Cells(k, 1).Value = Sheets("DataDec").Cells(l, 1).Value Then
foundTrue = True
Exit For
End If
Next l
If Not foundTrue Then
Sheets("DataJune").Rows(k).Copy Destination:= _
Sheets("AbsPres").Rows(lastRowAbsPres + 1)
lastRowAbsPres = lastRowAbsPres + 1
End If
Next k
'Stop screen from updating to speed things up.
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I've added some comments to explain what I'm trying to do. I'm relatively new to VBA so I believe I'm not coding very efficient.
Could someone have a look and try to make it work?
Basically what your are doing is comparing 2 column of elements, you want to know when:
an element is in both columns
an element is only in the first column
an element is only in the second column
To do that, your solution do:
For each element in column 1,
Find if there is this element in column 2
If found, it is in both, if not, it's just in 1
Continue to next element in column 1
Do quite the same with the element of the column 2
So basically, your examining column 2 for each element of column 1
And the same for the column 1 with the element of column 2
if we consider n the length of column1 and m the length of column2.
That is roughly 2*m*n comparison.
That's a lot !
My solution:
You are looking for numbers in column B.
Therefore you can sorted both sheet base on the value in column B
Then you can:
Create counter1 and counter2 referring to the current row in sheet1 and sheet2
Compare the value of sheet1.Value('B' + counter1) to sheet2.Value('B' + counter2)
Then you have 3 choice :
a) That is the same value, then copy the line in the right file and increments both counter
b) Value from sheet1 is greater, then you will never find the value from sheet2 in sheet1. So copy the line of sheet2 in the right file and increment only the counter2
c) The opposite
Do that until counter1 or counter2 is at the end.
As it is possible that both won't be at the end at the same time, you will have to copy the remaining lines in the right file as they will never be in the "finished" sheet.
With that solution, you will only read each "column" once ! So roughly about m+n comparison :)
You win a lot of time :)
With M=n=90 000:
you have a solution with about m*n=8 100 000 000 comparison
the other solution is just about 180 000 comparison
This should be the fastest approach as copying all data at once is much faster than copying it by row.
Select both columns > Home tab > Conditional Formatting > Highlight Cell Rules > Duplicate Values...
Now you need a filter from Data > Filter, but for that you will need to insert a header row above the numbers. After you have the filter, you can click on the second column filter and Filter by Color. Now you can copy the visible cells to wherever you copy the duplicates. I recommend sorting by color too before copying as copying one contiguous area should be a bit faster.
You can use the same method for the other two cases by filtering the columns with Filter by Color > No Fill.
Before you Record Macro of the process you can select View tab > Macros > Use Relative References.
Edit
I think I misunderstood the question. This method needs both columns to be next to each other, so if they are in separate sheets you can copy and insert them in column A. You can hide the column after the filter is applied. Then you can delete the column and header rows if needed.
Similar approach without conditional formatting is to inset a column with a helper function that checks if the id exists in the other sheet, but I think it will be a bit slower. For example:
= CountIf( Sheet2!A1:A1234, B2 )
I received an answer to my question on the Mr. Excel forum:
http://www.mrexcel.com/forum/excel-questions/963415-visual-basic-applications-speed-up-macro-large-file.html
Thanks for your answers!
The below mentioned data is for door access in a company where in we need to find the number of hours spent by a employee in office.
A employee can come in the office and swipe in and swipe out multiple times and all these details are register in the excel in non sorted order for all the employees.
I have a excel containing multiple columns
First two columns A,B are merged cells having date in this format(2015/01/25 7:27:30 PM).
The third column C has Access information having multiple entries for the below values(Entry/Exit).
For example
Column A Column B Access Employee ID Employee Name
==================================================
1. 2015/01/25 7:27:30 AM Entry 111 XYZ
2. 2015/01/25 7:30:30 AM Entry 333 ABC
3. 2015/01/25 8:30:30 AM Exit 111 XYZ
4. 2015/01/25 9:30:30 AM Entry 111 XYZ
5. 2015/01/25 9:30:30 AM Entry 444 PQR
6. 2015/01/25 10:30:30 Pm Exit 333 ABC
7. 2015/01/26 7:30:30 AM Exit 333 ABC
And so on.
Please note that the same employee can have multiple swipe in and out's throughout the day and will be clobbered among other employees information
The Goal is to as below
1) Copy the data from one sheet to another for the employees having spent time less than 9 hours for a specific day.
Here is the sample code that i have written it is work in progress
Sub HoursList()
Dim cell As Range
Dim cell1 As Range
Dim NewRange As Range
Dim NewRange1 As Range
Dim MyCount As Long
Dim ExistCount As Long
Dim ExistsCount As Boolean
Dim temp As Long
Dim MyCount1 As Long
Dim wsh As Worksheet, i As Long, lngEndRowInv As Long
Set wsh = Worksheets("Standard Door History ")
'Set cell = Range("A1")
ExistCount = 0
ExitsCount = False
MyCount = 1
MyCount1 = 1
i = 12
lngEndRowInv = wsh.Range("P" & wsh.Rows.Count).End(xlUp).Row
'----For every cell in row G on the Data sheet----'
For Each cell In wsh.Range("C12:D9085")
If cell.Value = "Entry" Then
'ExistCount = ExistCount + 1
If MyCount = 1 Then Set NewRange = cell.Offset(0, -1)
'----Sets up a new range to copy all data from the row if column in that row contains the value in question----'
Set NewRange = Application.Union(NewRange, cell.EntireRow)
MyCount = MyCount + 1
End If
Next cell
For Each cell1 In NewRange
If cell1.Value = "Mayur" Then
If MyCount1 = 1 Then Set NewRange1 = cell.Offset(0, -1)
'----Sets up a new range to copy all data from the row if column in that row contains the value in question----'
Set NewRange1 = Application.Union(NewRange1, cell.EntireRow)
MyCount1 = MyCount1 + 1
End If
Next cell1
If ExistCount > 0 Then
NewRange.Copy Destination:=Worksheets("Test").Range("A3")
End If
End Sub
Thanks
Here is a very rough version that you could use in VBA. It needs refining and error trapping, and future proofing, but it does what you want it to. It takes data from the active sheet and current adds it to the second worksheet. The date for looking up is in cell N1 of the first sheet.
Option Explicit
Sub CopyNine()
Dim LastRow As Integer
Dim DateToFind As Variant
Dim CellDate As Variant
Dim Count As Integer
Dim cel As Range
Dim DateRange As Range
Dim StaffID As String
Dim TimeStamp As Double
Dim StaffSummary As Object
Dim DS As Worksheet
Dim SS As Worksheet
Dim SSRow As Integer
LastRow = Range("A1").End(xlDown).Row
'You may wish to turn this into an input instead
DateToFind = Range("N1").Formula
Set DS = ActiveSheet
'You may wish to change this
Set SS = Sheets(2)
SSRow = 2
'Get a range containing all the correctly dated cells from the dataset
For Each cel In Range("A2:A" & LastRow).Cells
CellDate = Left(cel.Formula, InStr(1, cel.Formula, ".") - 1)
If CellDate = DateToFind Then
If DateRange Is Nothing Then
Set DateRange = cel
Else
Set DateRange = Union(DateRange, cel)
End If
End If
Next
'Create a summary dictionary of all staff IDs and their time spent in the office where 1 = 1 day
Set StaffSummary = CreateObject("scripting.dictionary")
For Each cel In DateRange.Cells
StaffID = cel.Offset(0, 3).Value
'These may need to be updated depending on your entry in the 'Entry/Exit' column
If cel.Offset(0, 2).Value = "Entry" Then
TimeStamp = -cel.Formula
Else
TimeStamp = cel.Formula
End If
If Not StaffSummary.exists(StaffID) Then
StaffSummary.Add StaffID, TimeStamp
Else
StaffSummary.Item(StaffID) = StaffSummary.Item(StaffID) + TimeStamp
End If
Next
'Copy the titles from the data sheet
SS.Range("A1:E1").Value = DS.Range("A1:E1").Value
'Copy the appropriate rows across using the dictionary you created
For Each cel In DateRange.Cells
StaffID = cel.Offset(0, 3).Value
If StaffSummary.Item(StaffID) <= 9 / 24 Then 'This is 9 hours so copy across
SS.Range("A" & SSRow & ":E" & SSRow).Value = DS.Range(cel, cel.Offset(0, 4)).Value
SSRow = SSRow + 1
End If
Next
End Sub
I would suggest using Excel's inbuilt abilities before VBA, especially if you are new to VBA. This will involve adding additional columns to your input sheet though which you can hide, but may not be ideal for your situation. It could also get quite slow as there are some large calculations, but it does depend on your original data set.
I would suggest the following (although there will be a lot of variations on it!):
1) Create a summary table for the particular day.
Create a date column in column F which is =TRUNC(A2) and copy down the table.
In M1 have your input date - e.g. 2015/01/25
In column L list all the unique Staff IDs
Below the date in M, use a SUMIFS formula and time formatting to determine how many hours each person spent. In M3 for example =SUMIFS($A:$A,$D:$D,$L2,$C:$C,"Exit",$F:$F,$M$1) - SUMIFS($A:$A,$D:$D,$L2,$C:$C,"Entry",$F:$F,$M$1) then formatting as hh:mm:ss.
In column N, use =M2<TIME(9,0,0) and drag down to work out if that individual has spent less than 9 hours in the building on that day.
You should now have a table showing all the staff and how many hours they spent in the building on that day, and a TRUE or FALSE whether they spent less than 9 hours.
2) Create your additional columns to pull the data to another sheet
In Column G, determine whether the entry is for the date in question (in cell M1) using =F2=$M$1 (should give a TRUE or FALSE)
In Column H, determine if that individual has spent less than 9 hours (from the summary table) using =INDEX(N:N, MATCH(D2, L:L,0))
In Column I, determine whether that entry should be copied across using =AND(G2, H2)
Finally in Column J, determine which entry this is to copy across using `=IF(I2, COUNTIFS($I$1:I2,TRUE),"")
Copy each of these down to the bottom of the table (you can hide them later)
3) Create your table on the next sheet for copying down - I have called my original worksheet "Data" and my second one "Copy"
In column A, use =ROW()-1 to create a sequential list of numbers
In column B, use =MATCH(A2, Data!J:J,0) to find out which row of data from the original table is being copied across
In column C, use =IFERROR(INDEX(Data!A:A,$B2),"") to pull the data from the first column
Copy this formula across to column G
Copy all of these down the sheet to however many rows of data you would like
Hide columns A, B and D since these will contain irrelevant information
You should then have an autoupdating table based on the date in cell M1 on the original data sheet. As mentioned above, this can be adapted in many ways, and it may not be ideal for your situation depending on your data set size, but it may be a start for you. If it is not suitable, then please use the theory to adapt some VBA code, as this can also be done in VBA in a very similar way.