I need to automate a process that's not a one-off event, ~500 facilities, each with 100+ assets which are all scheduled for different dates throughout the year for completion. I have a Workbook set up with my main/source sheet as well as 12 month sheets (Jan, Feb, March, ... Dec). What I need is some sort of code that would allow me to search for a particular date and send it as well as other same-row corresponding data to the appropriate sheet.
For example I have an asset that is due for maintenance in June, 6/17/11. I need for Excel to search for it using the month only, and moving that asset as well as it's name, description, cost, etc to the June tab. Ive managed to get it to locate assets searching for "6/" however it cannot find assets with a date of 6/17/11. It copies all needed data and attempts to move it to the proper sheet, when it makes this attempt a Microsoft Visual Basic error code 400 pops up. Any ideas? All help appreciated.
see if this helps ...
Private Sub FindCells()
'' step 1, find all the rows containing your date (June 2011 dates hardcoded in this example)
Dim CollectionOfRowRanges As New Collection
Dim ws As Worksheet
Dim rgCell As Range
For Each ws In ThisWorkbook.Worksheets
For Each rgCell In ws.UsedRange.Cells
If IsDate(rgCell.Text) Then
If Month(CDate(rgCell.Value)) = 6 And Year(CDate(rgCell.Value)) = 2011 Then
'' for debugging only ... watch and make sure it stops at the right places
ws.Activate
rgCell.Select
Stop
'' end of debug code
Call CollectionOfRowRanges.Add(rgCell.EntireRow)
End If
End If
Next rgCell
Next ws
'' step 2, copy the rows to a new wb
Set ws = Workbooks.Add.Sheets(1)
ws.Name = "June 2011 Rows"
Dim rgRow As Range
Set rgCell = ws.Cells(1, 1)
For Each rgRow In CollectionOfRowRanges
Call rgRow.Copy
Call rgCell.EntireRow.PasteSpecial(xlPasteValues)
Set rgCell = rgCell.Offset(1)
Next rgRow
End Sub
Related
I have a data set of around 1500 sales records. I have written a macro, which would create product category specific work books, which would have an individual work sheet for each product in the product category.
The macro is working as expected, but I have found out that it is consistently ignoring some products. I put debug statements to see if I am getting zero records when I filter based on the product code (since I use this selection to paste the records to a separate work sheet). The selection seems to be working fine, as I get the number of rows selected.
A pattern I saw was that the product codes which were having zero records were generally the first ones or the last ones to get processed before or after a file operation (either I open a category specific work book, or I am closing a work book). But even here, the table header was copied to the individual work sheet. Only the data rows were getting ignored.
Is there a chance where the macro is processing the records too fast, while there is some time lag in doing File I/O operations (which makes a few records to get ignored)?
I am attaching the code, which I have used for looping
'loop through each row and get the product id and the category (Ann & Bnn).
' Dim catWorkBook As Workbook
oProductCat = "0" 'the initial value set as 0, which would NEVER be a category
With wkScrap 'this is a rough sheet which has the product items and categories
For i = 2 To lProdRow
cProductCode = .Cells(i, 1).Value
cProductCat = .Cells(i, 2).Value
'FILE OPEN: will need to open a category specific .xls file
If (StrComp(cProductCat, oProductCat) <> 0) Then
'save the existing workbook
FileIO.CloseExcelFile oProductCat, catWorkBook
Set catWorkBook = Nothing 'clear all traces of the old worksheet
Set catWorkBook = CreateBlankWorkBook()
oProductCat = cProductCat
End If
'COPY DATA: Filtering on product code, and then moving it into a new
'worksheet
CopyCategoryToWorksheet cProductCode, catWorkBook
If i = lProdRow Then
'we are at the end of the loop. Proceed to close the current
'workbook
FileIO.CloseExcelFile oProductCat, catWorkBook
End If
Next
End With
Here is the function which does the actual copying
Private Sub CopyCategoryToWorksheet(prodCode As String, catWkBook As Workbook)
'check for a meaningful prod code
If (Trim(prodCode & vbNullString) = vbNullString) Then
Exit Sub
End If
Dim wkRData As Worksheet
Dim rRData As Range
Dim rDataMaxRows As Integer
Set wkRData = SalesReport.Sheet1
'We know that we have to create a work sheet for this product code.
'Let us do that first.
Dim prodCatSheet As Worksheet
catWkBook.Activate
Set prodCatSheet = catWkBook.Sheets.Add(After:=catWkBook.Sheets(catWkBook.Sheets.Count))
prodCatSheet.Name = prodCode
wkRData.Activate 'for this sub routine, all processing is happening on the raw data sheet
rDataMaxRows = Cells(rows.Count, 1).End(xlUp).Row
Set rRData = Range("A1:H" & rDataMaxRows)
rRData.AutoFilter 3, Criteria1:="=" & Trim(prodCode)
rRData.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'activate the newly created sheet, and paste all the selected rows there
prodCatSheet.Activate
prodCatSheet.PasteSpecial
Set wkRData = Nothing 'just clear some memory
End Sub
I am trying to simplify a process for field employees at my work. The baseline case is that the employees fill out Daily Detail Reports in a single Excel Workbook throughout the year with the hours they have worked that day, the project # and Phase Code their labor costs will hit and the hours that they worked that day on that particular project. It is very common for the same project number and phase code to be used more than once for a single day (i.e. multiple row entries which will need the total hours added together based on the condition of having the same project number and phase code for that day). See attached "Detail Report WB" image.
Our employees then have to enter the same data in a different format (i.e. only one line allowed per project number and phase code pair per day) in a separate workbook. See attached "Timesheet Import WB" image. The timesheet workbook is driven based on the week end date for that week (i.e. Sunday). The Daily Detail Report workbook however, is driven based on the week beginning date and Sundays are not included in the Daily Detail Report. To make things more complicated, the dates listed in the Daily Detail report are based on formulas and do not house the actual date value in the cells.
The goal of this solution is to take the information entered into the Daily Detail Report workbook and place it into the Timesheet workbook via a sub function based on a ActiveX command button click event. See the attached “End Goal” image.
So far I have compiled the following code to allow the user to click the import button which prompts the user to find the Daily Detail Report workbook that they would like to import data from. This code also allows for the user to input the week end date desired for the Timesheet workbook. I was trying to use the week end date to find the desired data in the Daily Detail Report workbook, but this is proving difficult. Any assistance would be greatly appreciated. It’s been years since I took into to computer programming in VBA back in college.
Images are located here: https://drive.google.com/drive/folders/0B7BjXxM59FFyQlM5eThvc0dDWUU?usp=sharing
Thanks!
Private Sub CommandButton1_Click()
'Define All Variables
Dim GCell As Range
Dim fDialog As FileDialog, result As Integer
Dim MyDetailReport As String
Dim MyTimeSheet As String
Dim MySheet As String
Dim ProjNum As String
Dim PhaseCode As String
Dim Hours As String
Dim WkEndDate As String
'Find source file
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
fDialog.AllowMultiSelect = False
fDialog.Title = "Select Daily Report File to Import"
fDialog.InitialFileName = "W:\PDX - Mechanical Construction\Operations\Detailing\Daily Tracking Logs\"
fDialog.Filters.Clear
fDialog.Filters.Add "Excel files", "*.xlsx"
If fDialog.Show = -1 Then
MyDetailReport = fDialog.SelectedItems(1)
End If
'Enter date to look for in workbook
WkEndDate = InputBox("Insert Week End Date in format mm/dd/yyyy", "User date", Format(Now(), "mm/dd/yyyy"))
If IsDate(WkEndDate) Then
WkEndDate = Format(CDate(WkEndDate), "mm/dd/yyyy")
'Place Week End Date into Timesheet workbook
With ThisWorkbook.ActiveSheet.Range("AE5")
.Value = WkEndDate
End With
Else
MsgBox "Wrong date format"
End If
'Use the current sheet to store found data
MySheet = ActiveSheet.Name
'Use Error Handling routine in case of errors
On Error GoTo ErrorHandler
'Turn off screen updating to run macro faster
Application.ScreenUpdating = False
Workbooks.Open Filename:=MyDetailReport & MyTimeSheet
'Search Detail Report "Daily Report Log" sheet for the selected Week End Date
Set GCell = ActiveSheet.Cells.Find(WkEndDate, LookIn:=xlValues)
GCell = GCell.Offset(2, 1)
If GCell.Value = "" Then
GCell = GCell.Offset(1, 0)
Else
'copy data formulas to correct format for Timesheet workbook
End If
'Error Handling
ErrorHandler:
Select Case Err.Number
'Common error #2: the specified data wasn't in the target workbook.
Case 9, 91
Application.ScreenUpdating = True
MsgBox "The value " & WkEndDate & " was not found."
Exit Sub
'General case: turn screenupdating back on, and exit.
Case Else
Application.ScreenUpdating = True
Exit Sub
End Select
End Sub
I am creating a workbook with 17 sheets and each one has a product list that will change from month to month. If a product has errors, it shows up as CMB in the values but the product is still there. I was to delete the product rows. This code works on a sheet by sheet basis, but once I try to loop it, it does not work.
Sub wsLoop()
Dim ws as Worksheet
For Each ws In Worksheets
'Seeing if there are new products added to list
countcells = Range(Range("F8").End(xlDown).Offset(, -4), Range("A8").End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count
'if no products added, then see if there in CMB in any row and delete that row
If countcells = 1 Then
If Not Range("E:E").Find("CMB") Is Nothing Then
Range(Range("E:E").Find("CMB"), Range("E8").End(xlDown)).Rows.EntireRow.Delete
End If
End If
Next ws
End Sub
You have to actually get the range of the current worksheet. E.g.,
countcells = ws.Range(ws.Range("F8").End(xlDown).Offset(, -4), ws.Range("A8").End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count
Otherwise, you will always be just grabbing ranges off the currently selected worksheet (which will generally be the first worksheet).
Note that you will need to repeat this for all instances of Range.
By the way, one thing you can do to make this easier is to use With:
With ws
countcells = .Range(.Range("F8").End(xlDown).Offset(, -4), .Range("A8").End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count
'repeat for all lines
End With
With eliminates the need to repeat the name of the object over and over. You just type .property, and it automatically knows you mean ws.property.
Ok Hi everybody,
I've been looking into this and trying to figure it out for a couple days now. I've found things close but nothing matches what I need.
I have 13 departments here and each department has a sheet with issues that need to be resolved. What I need is when each of those departments updates their excel sheet with an issue it updates on the master list (which is in the same workbook). Since people are constantly deleting and adding the formula would need to stay.
Would it be easier to have them enter the data on the master sheet and have that go into the individual files? If so how would I even do that? Thanks in advance. I'm trying to see if an advance filter or something would work but can't get it just right.
You will need to adjust the names in my code but if you paste this code in each of your department sheets (not the master list) you should get your desired result:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim xlws As Excel.Worksheet
Set xlws = ActiveSheet
For i = 1 To 13
If IsEmpty(xlws.Cells(2, i).Value) = True Then
Exit Sub
End If
Next
Dim xlwsMaster As Excel.Worksheet
Set xlwsMaster = ActiveWorkbook.Worksheets("master list")
i = 1
Do While IsEmpty(xlwsMaster.Range("A" & i).Value) = False
i = i + 1
Loop
xlws.Range("A2:M2").Copy
xlwsMaster.Range("A" & i).PasteSpecial xlPasteAll
xlws.Range("A2:M2").Clear
End Sub
every time there is a change on one of those sheets it will check to see if all the values of a through m are filled if they are it copies a2:m2 and pastes it at the first empty row on the master list and then clears a2:m2 on the sheet in question
I'm trying to automate a report that for a customer and I'm a bit stuck with one of the hurdles that needs to overcome, I have some ideas but am new to VB programming.
The requirement is to copy a range of cells from one sheet to another, but the destination needs to change depending on the current date. Using a general example I'm trying to achieve the following:
If the date is the 1st of the month, the destination range is B2:F3, if it is the 2nd then the destination range is B4:F5, if the 3rd then destination is B6:F7....... if the 31st then the destination is B62:F63, the source ranges are static.
I figured I could probably achieve this by writing a huge script which contained an IF statement for each day of the month, but I was hoping I could be a bit smarter and use variables to assign the row references at the beginning of the script then just sub them back into the select/copy statements.
Absolutely you can.
Dim x as Integer
Dim daymonth as Integer
Dim rw as String
daymonth = CInt(Format(date, "d"))
x = daymonth * 2
rw = CStr(x)
Now you can use range like:
Range("D" & rw & ":F" & CStr(x + 1))
Just an example. Then since the number is constant between the two ranges just add that number to x and use it in the range.
You may want following subroutine.
Sub copyDataDependOnDatte()
Dim today As Date, dayOfToday As Integer
Dim sWS As Worksheet, dWS As Worksheet
'set two worksheets to variables
Set sWS = Worksheets("source") 'Worksheet which has data to be copied
Set dWS = Worksheets("destination") 'Worksheet which is used to record data of days.
' get day of today
today = Now() 'get date of today
dayOfToday = Day(today) ' get day of today
Range(sWS.Cells(2, 2), sWS.Cells(3, 6)).Copy 'copy B2:F3 of worksheet "source"
dWS.Cells(dayOfToday * 2, 2).PasteSpecial ' paste to worksheet "destination" at place determined by day of today
End Sub
In this code,I assumed following for writing concreat code.
"source" is name of worksheet which contains the data to be copied
"destination" is name of worksheet which records tha data copied from "source" worksheet
Data to be copied is exist at "B2:F3" of worksheet "source"
Please change worksheets' names to real names of your data.
Place of data to be copied is described as "Range(sWS.Cells(2, 2), sWS.Cells(3, 6))" in the code.
cells(2,2) means cell on 2nd row and 2nd column, i.e. "B2".
Cells(3,6) means cell on 3rd row and 6th column, i.e. "F3".
Plese correct place to fit your data.