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.
Related
I'm trying to provide the capability to select either a row or column in a row and copy certain cells off the row into a different sheet.
For example...I have a list of renters (rows) each with the amount they owe and the amount collected on one sheet and the other sheet is a receipt. I'd like to enter the rent collected and have the receipt sheet updated automatically with the other sheets rows/individuals name and amount collected.
Is there a VB function to identify the active row?
If I can get that working the next thing would be adding/incrementing the invoice number.
You can use a combination of UsedRange and the Rows() property to get your active row.
While UsedRange is not necessarily required, it would only select the used cells in that row as opposed to selecting the entire row of the workbook, which is very likely unneeded.
You can use this function:
Function rngActiveRow() As Range
Dim ws As Worksheet
Set ws = ActiveCell.Parent
Set rngActiveRow = ws.UsedRange.Rows(ActiveCell.Row)
End Function
If you wanted to test it, you can try calling this function in a test sub to see it work:
Sub test()
rngActiveRow.Select
End Sub
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
Use case: I want to copy data from column A to Column B (where column A, B are arbitrary columns). Once the data is in Column B, I want to remove duplicate entries within column B.
Make a loop that moves data from column A to column B and then removes duplicates for each sheet in a workbook.
`Sub Copy()
For i = 1 To Sheets.Count
Worksheets(i).Range("A1:A100")
Destination:=Worksheets(i).Range("B1")
Next
End Sub
`
For testing I separated the tasks into two different Sub(). Sub Copy() is working and correctly copies my data. Sheet1 is also named "Sheet1" for my specific workbook
`Sub RemoveStuff()
Dim rng As Range
For j = 1 To Sheets.Count
Set rng = Worksheets("Sheet1").Range(Range("B1"),Range("B1").End(xlDown)).Select
rng.RemoveDuplicates Columns:=(1), Header:=xlGuess
Next
End Sub
`
My error seems to be in defining the range correctly. Each sheet will have a different number of entries to remove duplicates from. Sheet1 might have 50 rows and reduce to 6. Sheet2 could have 70 and reduce to 3. Sheet3 could have 20 rows and reduce to 12 uniques. Excel does not let you remove duplicates from range (B:B!)
How can I properly define my range so I can remove duplicates in a loop for a dynamically defined range for each sheet(sheet=tabs in workbook)?
EDIT 2-23-17
New code from Y0wE3K
Sub RemoveStuff()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Columns("P:P").RemoveDuplicates,Columns:=1, Header:=xlYes
Next
End Sub
Still does not work. If I manually select Column P before I run the macro, it works. But it only goes for the one sheet I have selected, it does not seem to execute the loop. Definitely does not automatically do each sheet, or prompt me for each one.
EDIT: 3/4
Make sure that you do not have any protected data, I also experienced issues with pivot tables but I think this may be permissions thank you for help.
Your RemoveStuff subroutine can be rewritten as:
Sub RemoveStuff()
Dim ws As Worksheet
For Each ws In Worksheets ' Use Worksheets instead of Sheets,
' in case there are any Charts
'You can just select the whole column, rather than selecting
'specific rows
ws.Columns("B:B").RemoveDuplicates Columns:=1, Header:=xlGuess
Next
End Sub
Sub RemoveStuff()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Columns("P:P").RemoveDuplicates,Columns:=1, Header:=xlYes
Next
End Sub
This code will work. As a final note, please make sure you have no Protected Data, or pivot tables inside of the sheets you need to run the remove script on. For whatever reason that caused mine to fail, but running my script on the correct sheets that are unprotected worked GREAT.
Please find my requirement below for which I am unable to find any solution:
1. Iterate over workSheet from workbook
2. Find all the columns containing date values using current format/type of column (Here is a trick. Worksheet is not static, it can contain any number of columns containing date values. Columns containing date values may have any name. And such worksheets can be more than one in number)
3. Apply macro on date columns for date formatting (below macro) if "Flag" value is "y"
<code>
Sub FormatDate()
If wksSecDist.Range("Flag").value = "y" Then
LastRowColA = Range("X" & Rows.Count).End(xlUp).Row
' Here I am finding total number of rows in column X
wksSecDist.Range("X2", "X" & LastRowColA).NumberFormat = "dd/mmm/yyyy"
' Here applying specified date format to Range("X2", "X10") [if last row index for column X is 10]
End If
End Sub
</code>
I am just a beginner to VBA.
Thanks in advance.
I suspect you didn't find a solution on the internet because you looked simply for a solution and not the parts needed to build your own solution.
You mention you are a VBA beginner, please take the below answer to be of educational use and begin you in getting you where you need your tool to be. Note, if it doesn't answer your question because of information that was not included, it has still answered your question and the missing information should form part of a new question. That said, lets get this function up and running.
From what you have written I have interpreted the requirement to be: -
Look over all worksheets in a workbook ('worksheets can be more than one in number')
Check every column to see if it holds a date value
If it does, set the whole column to a specific format
What is needed to accomplish this is iteration(loops), one to loop through all worksheet, and another to loop through all columns: -
The is pseudo code of the target: -
.For each Worksheet in the Workbook
..For each Column in the Worksheet
...If the Column contains dates then format it as required
..Process next column
.Process next Worksheet
We achieve this using a variable to reference a Worksheet and using a loop (For Each) to change the reference. The same goes for the columns.
Public Sub Sample()
Dim WkSht As Excel.Worksheet
Dim LngCols As Long
Dim LngCol As Long
'This loop will process the code inside it against every worksheet in this Workbook
For Each WkSht In ThisWorkbook.Worksheets
'Go to the top right of the worksheet and then come in, this finds the last used column
LngCols = WkSht.Range(WkSht.Cells(1, WkSht.Columns.Count).Address).End(xlToLeft).Column
'This loop will process the code inside it against every column in the worksheet
For LngCol = 1 To LngCols
'If the first cell contains a date then we should format the column
If IsDate(WkSht.Cells(2, LngCol)) Then
'Set right to the bottom of the sheet
WkSht.Range(WkSht.Cells(2, LngCol), WkSht.Cells(WkSht.Rows.Count, LngCol)).NumberFormat = "dd/mmm/yyyy"
End If
Next
Next
End Sub
Hopefully that has all made sense, this does work on the premise that the header row is always row 1 and there are no gaps in the columns, but these are separate issues you can approach when you're ready to.
So, I've explored a few answered VBA Questions, but I'm still stuck. I have three sheets "By_Oppt_ID", "Top_Bottom" and "Non_Top_Bottom". The first two have a large amount of columns each with a unique name. Now there are some columns in By_Oppt_ID that aren't in "Top_Bottom". So I want to compare each column name in By_Oppt_ID to every column name in "Top_Bottom", and if the column name isn't found, copy that column name and all the rows beneath it, to a third worksheet "Non_Top_Bottom".
So Here's what I have:
Sub Copy_Rows_If()
Dim Range_1 As Worksheet, Range_2 As Worksheet
Dim c As Range
Set Range_1 = Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Top_Bottom")
Set Range_2 = Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("By_Oppt_ID")
Application.ScreenUpdating = False ' Stays on the same screen even if referencing different worksheets
For Each c In Range_2.Range("A2:LX2")
' Checks for values not in Range_1
If Application.WorksheetFunction.CountIf(Range_1.Range("A1:CR1"), c.Value) = 0 Then
' If not, copies rows to new worksheet
' LR = .Cells(Row.Count, c).End(xUp).Row
c = ActiveCell
Sheets("By_Oppt_ID").Range("Activecell", "ActiveCell.End(xlDown)").Copy Destination:=Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Non_Top_Bottom").Range("A1:A6745")
Set rgPaste = rgPaste.Offset(0, 1) 'Moves to the next col, but starts at the same row position
End If
Next c
End Sub
I've compiled this many ways and keep getting a series of errors: Subscript Out of Range/ Method "Global_Range" Failure. What am I doing wrong?
If you are going to have this code within the same workbook every time, try using
ThisWorkbook.Sheets("Top_Bottom")
instead of
Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Top_Bottom")
replicate that through your code and see if that fixes the problem.
What do you mean by c = Activecell? Do you mean to say c.activate?
You might then also want to change the next line to
Sheets("By_Oppt_ID").Range(Activecell, ActiveCell.End(xlDown)).Copy Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Non_Top_Bottom").Range("A1")