Okay, so don't mind the title, I had trouble summarizing my current issue. But first here is what I am trying to do :
I have three sheets, first one is containing a list of Attributes, the second a list of Categories and the third a cross table associating Attributes and Categories.
The code i'm working on is quite straightforward : when selecting one or many attributes (or categories) using checkboxes and executing the macro, the code will look for ticked checkboxes, get the ID associated to the selected attributes (or categories), then delete the line in the attribute (or category) worksheet and also in the cross table.
The sheets looks like that :
*Attribute Sheet*
*Category Sheet*
*Cross Table*
And here is my code :
Sub Delete_Selection()
Dim Wb As Workbook: Set Wb = Workbooks("DataBase WIP.xlsm")
Dim Sws As Worksheet: Set Sws = ActiveSheet
Dim CrossWs As Worksheet: Set CrossWs = Sheet6
Dim Cb As CheckBox
Dim Checking As Range
Dim LastRow As Long: LastRow = Sws.Cells(Sws.Rows.Count, "B").End(xlUp).Row
Dim CRow As Long, IDColumn As Long, IDRow As Long
Dim CID As String
IDColumn = Sws.Cells.Find(What:="ID", LookAt:=xlWhole).Column 'Look for the ID column in the current sheet
MsgBox (IDColumn) 'Debug purpose
For Each Cb In Sws.Checkboxes
If (Cb.Value = 1) Then 'If checkbox is ticked, proceed
CRow = Range(Cb.LinkedCell).Row 'Get the row number of the checkbox
MsgBox (CRow) 'Debug purpose
CID = Cells(CRow, IDColumn).Value 'Get the ID value
Rows(CRow).Delete Shift:=xlUp 'Delete the row
Cb.Delete 'Delete the checkbox
If (ActiveSheet.CodeName = "Sheet2") Then 'If attributes are being deleted, proceed
MsgBox (CID) 'Debug Purpose
IDRow = CrossWs.Cells.Find(What:=CID, LookAt:=xlWhole).Row 'Find the corresponding row in the cross table
CrossWs.Rows(IDRow).Delete Shift:=xlUp 'Delete it
End If
If (ActiveSheet.CodeName = "Sheet5") Then 'If categories are being deleted, proceed
MsgBox (CID) 'Debug Purpose
IDColumn = CrossWs.Cells.Find(What:=CID, LookAt:=xlWhole).Column 'Find the corresponding column in the cross table
CrossWs.Columns(IDColumn).Delete Shift:=xlToLeft 'Delete it
End If
End If
Next
End Sub
The issue :
The code works perfectly fine when selecting and deleting multiple attributes
The code works when selecting and deleting one category
BUT : when selecting multiple categories and running the deletion code, it deletes them all in the category sheet but it only delete one corresponding column in the cross table.
Example : if I want to delete the beef and beans category, I select them using the checkboxes then press the button, in the category sheet they're all successfully deleted (yay !) but only the beef column will be deleted in the crosstable.
So to figure out why, I decided to print the relevant variables, what is happening in the previous example is the following :
IDColumn = 1 which is normal
CRow = 10 fine too
CID = DOC9 expected
Then
IDColumn = 1 Wasn't supposed to change
Crow = 10 The rows have been shifted up to fill the gap so totally normal
CID = "" And that's where my issue is.
Despite looking at the right cell, CID don't get the value contained in it and I don't understand why at all.
Important precision, the attribute sheet is perfectly normal while the category sheet contains a Table ! I think that's where the issue lies but I couldn't find anything useful on the Internet.
And I don't understand why the program would be able the read the value of a cell the first time and then doesn't. I may have missed something obvious so I apologize if its the case but any help would be greatly appreciated !
Edit 1 : It has nothing to do with the Categories being in a table, I wrote a similar code but I ran into the exact same issue even without looking at a Table. I still don't know what's happening.
I found a workaround by first reading all my ID's and storing them into an array and then looping through my array to modify my cross table. I will probably do the same for my current issue.
Okay, I found the problem.
Once again I wasted a lot of time because of a stupid mistake.
When I was deleting a category, I needed to find the column linked to that category in my cross table, and I stupidly used the same variable referring to the ID column of my Category sheet (i.e. "IDColumn"), changing its value and therefore when reading the next ID, my code was looking in the wrong cell.
Thanks to anyone who have tried to help me ! I will hopefully not make a fool of myself next time ahah.
Related
I'm creating an excel workbook that has a dashboard on the front page of it. when two dates are selected from a drop down and the "refresh data" button is pressed, it runs a macro that fills in all the charts and tables on the dashboard page based on data tables in other worksheets within the workbook.
I'm trying to add a layer of dynamism so that if a date is selected where not all information, or even any information, is to be found, it lets the user know. (some information can be late coming to the work book)
So far I've tried a few ways with the closest maybe being the following options, but none of them work properly.
The beginning code is
Sub Macro3()
Dim DataM As Variant
Dim DataY As Variant
Dim ws1 As Worksheet
Dim DD1 As OLEObject
Dim DD2 As OLEObject
Dim i As Byte
Set ws1 = Worksheets("KPI Dashboard")
Set DD1 = ws1.OLEObjects("DMonth") 'this is the month input
Set DD2 = ws1.OLEObjects("Dyear") 'this is the year input
Set DataM = DD1.Object
Set DataY = DD2.Object
'part 1 is for utilisation
Set ws2 = Worksheets("People Info")
ws2.ListObjects("Utilisation").Range.AutoFilter Field:=2, Criteria1:=DataM.Value
ws2.ListObjects("Utilisation").Range.AutoFilter Field:=1, Criteria1:=DataY.Value
My first attempt was to count the rows in the databodyrange, but every time I tried that I would get an error saying there was no cells. I know I oculd normally put an "on error" line of code, but I want it to highlight to the user that there is a table missing data and then go onto the next table and keep going. I don't know of any ways in which I could dynamically have error responses in one function to the same error.
My second attempt was to just count the tables overall rows, with a msgbox to say there was no data like below:
If ws2.ListObjects("Utilisation").Range.SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then
If MsgBox("It Looks like we have no data for Utilisation, please fill it in and run it again. do you want to continue?", vbYesNo) = vbNo Then
Exit Sub
End If
ws2.ListObjects("Utilisation").AutoFilter.ShowAllData
GoTo S1P2
End If
But it always returns the count of rows as 1, even when I can see that it clearly has 5 or 6 rows in it.
So the last thing I tried was to select the area, and see if I could count that selection to greater success, but again it would still return 1, even on the count
Can anyone think of a better way to try it?
I have also tried using the IsEmpty() function and a handful of others like that but can't seem to get it to work. it either says there are no cells in the databody range, because they have been queried out or it says there is 1 row in the table range, even when there isn't.
Any help on how to make it work, or even a different avenue with which to look down would be really helpful.
I'm new to the world of VBA and can't quite wrap my head around this macro I want to create.
Essentially, I have a monthly data set that comes in, but the data is imperfect. I often need to clear excess data values of one cell, based on the value of another.
The complex part is that the data will be displaced week to week, and the only thing that is static are the column headers that are included.
Just as an example, columns A thru E have headers Company1, Company2, Company3, etc.
Columns Q thru U have headers Product1, Product2, Product3, etc.
The product columns will contain the company names as values (often more than one, delimited by commas), and if the name of a company doesn't appear for ANY of the product columns, the cell of the same row for that company's column should be cleared.
So if Q4:U4 doesn't contain "Product1" as as value, the value at A4 (product 1 column, row 4) should be cleared.
Any insight on how to go about this would be much appreciated!
edit
Screenshot of example data:
Example 2
Try this. Create a new module within the VBA editor and copy in the below code ...
Public Sub ProcessData()
Dim objCompanyRange As Range, objProductRange As Range, objCompanyCell As Range
Dim strCompany As String, objThisProductRange As Range, rngFrom As Range
Dim rngTo As Range, objFindResult As Range, lngLastRow As Long
On Error Resume Next
' Get the range for the company data.
Set objCompanyRange = Application.InputBox("Please select the COMPANY data range, including headers ...", "Company Data", , , , , , 8)
If Err.Description <> "" Then Exit Sub
' Get the range for the product data.
Set objProductRange = Application.InputBox("Please select the PRODUCT data range, including headers ...", "Product Data", , , , , , 8)
If Err.Description <> "" Then Exit Sub
On Error GoTo 0
For Each objCompanyCell In objCompanyRange
' We want the headers in the range but want to skip processing the first row.
If objCompanyCell.Row > objCompanyRange.Cells(1, 1).Row Then
' This is the only contentious line for me. If your headers are specified as you had in your
' example, i.e. "Group: Company1" then the below will work. If that was a mocked example that
' was not 100% accurate, the below line will need to change. It is currently splitting the header
' by a colon and only storing the right hand side as the company.
strCompany = Trim(Split(objCompanyRange.Cells(1, objCompanyCell.Column).Text, ":")(1))
' Only reset objThisProductRange if the row has changed, otherwise we use the same set of
' products we used last time.
If objCompanyCell.Row <> lngLastRow Then
' Determine the range for the product data given the current row being processed
With objProductRange.Worksheet
Set rngFrom = .Range(.Cells(objCompanyCell.Row, objProductRange.Cells(1, 1).Column).Address)
Set rngTo = rngFrom.Offset(0, objProductRange.Columns.Count - 1)
End With
Set objThisProductRange = Range(rngFrom.Address & ":" & rngTo.Address)
End If
' Find the company name within the current row of Product data.
Set objFindResult = objThisProductRange.Find(strCompany, MatchCase:=False)
' Clear the cell if nothing was found.
If objFindResult Is Nothing Then
objCompanyCell.ClearContents
End If
End If
lngLastRow = objCompanyCell.Row
Next
End Sub
... now watch the animated GIF below to see how you launch it and the resulting output.
If selecting the datasets each time gives you the sh!ts then feel free to hardcode it or use your own determination method. It's the easiest approach given I don't know how you may want to do that.
Here's hoping it's what you're after. Be sure to read the comments in the code in case you have any questions.
I have a large file that I am working on and need to be able to calculate people DOB. I have attached a sample file here to get an idea.... but basically what I am looking to do is ONLY if data exists in the "DOB" column, for "Age" to be calculated.
DOB will be listed in every other column for up to 18 different people (so column A, C, E.....) In columns B, D, F..... I am looking to have the age be calculated in years.
The catch is, there will NOT always be data for 18 people, so this is something that would only need to calculate IF data is present in the DOB column.
Ideally this would be a macro that I would run when I open the file so that all of the ages can update.
How do I even go about doing something like this?
I would expect output to just show age in years.... so if DOB was 01/01/2001 - age would show as 18
I'm going to make the assumption that VBA is overkill. This worked for me ...
=IF(A1="","",ROUNDDOWN(YEARFRAC(A1,NOW()),0))
If you were looking at a VBA solution, the above formula is translatable directly to VBA. It's not complete in relation to your context but that's a bigger piece that is hard to inject into without seeing your code at present ...
Public Sub WriteAgeToCell()
If Range("A1").Text <> "" Then
Range("A2") = WorksheetFunction.RoundDown(WorksheetFunction.YearFrac(Range("A1"), Now), 0)
End If
End Sub
Using Workbook_Open() in your Workbook object can be used to automatically recalculate what you need.
So to put it all together, and with a little bit of compromise, you can do the following ...
Private Sub Workbook_Open()
Dim objSheet As Worksheet, lngAgeCol As Long, lngEndRow As Long, i As Long
Dim lngStartRow As Long
With Range("rngHeaderAge")
Set objSheet = .Worksheet
lngAgeCol = .Column
lngStartRow = .Row + 1
End With
lngEndRow = objSheet.Cells.SpecialCells(xlLastCell).Row
For i = lngStartRow To lngEndRow
objSheet.Cells(i, lngAgeCol).FormulaR1C1 = "=IF(RC[-1]="""","""",ROUNDDOWN(YEARFRAC(RC[-1],NOW()),0))"
Next
End Sub
When the workbook is opened, it will fill down the formula from the row below the header column and then if DOB's are changed during the session, the age will update on the fly.
To make the above work, all you need to do is update the code into the Workbook object within the VBA editor and create a named range against the header for the age column, as shown below.
I have a sheet named "Staffdb" with two named tables "PermTBL" and "StaffTBL", same headers "Girls" "ID" "Hire_date" and "Status". All of the current and historic staff are in PermTBL. I would like to filter PermTBL on the Status field for "A" meaning active and then copy these to the StaffTBL which is empty. After manually filtering the PermTBL with the Status down arrow and select only "A" I go in to test the code and get an apparent partial copy. My code is
Option Explicit
Sub PermTBLtoStaffTBL()
Dim rgnsrc As Range
Dim rgndest As Range
Set rgnsrc = Worksheets("Staffdb").Range("PermTBL")
Set rgndest = Worksheets("Staffdb").Range("StaffTBL")
rgnsrc.SpecialCells(xlCellTypeVisible).Copy rgndest
End Sub
Finally as an additional piece of information the StaffTBL appears to have hidden rows, 3-7 are not visible which appears to correspond with my missing data. I have tried to unhide to no avail. Suggestions as to where to go next? Must I loop through the table or have I made an error in my destination? New at this, and 3rd world internet speed, along with inability to have books delivered makes this a tedious process. Please bear with the NewBee.
New piece of information, I have found that if I unhide the entire sheet the correct data appears in the StaffTBL, of course the filter of the PermTBL also disappears, so apparently I was on the right track. Would still like comments and suggestions on programmatically (as opposed to manually) filtering PermTBL. I will continue to search sites for that, but any suggestions are appreciated.
Sub CopyData()
Dim t As ListObject
Dim t2 As ListObject
Set t = ActiveSheet.ListObjects("PermTBL")
Set t2 = ActiveSheet.ListObjects("StaffTBL")
' Remove all rows from StaffTBL table
If Not t2.DataBodyRange Is Nothing Then
t2.DataBodyRange.Rows.Delete
End If
' Filter Status by "A"
t.DataBodyRange.AutoFilter Field:=4, Criteria1:="A"
' Copy to first cell right below the table's header
t.DataBodyRange.Copy t2.Range(1).Offset(1)
' Remove filter from PermTBL table
t.DataBodyRange.AutoFilter
End Sub
UPDATE
Example workbook
Here's my dilemma, I need to parse a series of 606 weeks worth of Billboard 200 charts for the position of 36 different albums. Here's what I've got so far...
https://docs.google.com/file/d/0B_tgNfDq0kXAakR5eHZ3bzJQVkk/edit?usp=sharing
Billboard just redid their website, so now Excel's webquery returns a very pretty and clean table. I created two formulas in columns A and B of my worksheet, A has the list of relevant dates (specifically every Saturday from 8/18/2001 until this week), and B makes hyperlinks to the charts based on the dates. The rest of the chart is color-coded for the benefit of my advisors, who will also be reviewing the sheet.
I've also manually webqueried the first chart, dated 2001-08-18, into its own worksheet. This worksheet hasn't been touched - its exactly what the webquery returned.
As you can see, the table spans to column G, and each entry takes up 3 rows. My focus is on columns C and D. Column D's rows for each entry are (top-to-bottom) Title, Artist, and Imprint|Label. The first row in Column C for each entry contains that week's position from 1 to 200. The pattern that emerges is that every 3rd row starting with 4 (so 7, 10, 13...) contains a position and album title (col C & D, resp.), and every 3rd cell starting with 5 contains an artist.
I'm going to try to explain what I'm imagining in plain English, but be forewarned that this may fail miserably.
So the macro would take two cells as input (can they even take input?), album title and corresponding artist. This input should tell the macro both the string stored in each cell and the location - e.g, E1, C2 - of said cell. The macro should loop through each URL in column A from row 3 to 608, querying the URL into a new sheet. This new sheet should be made active, and then every 3rd row starting with 4 should be searched sequentially for the album title string. Upon finding a match, the cell one row beneath the matching query cell should be compared to the artist name string. Should both strings match the content of their corresponding query cells, the number (from 1 to 200) in column C and the same row as the matching album title cell should be copied to the cell in the 'bb200' sheet corresponding to the URL queried and the album title searched. The loop should now recur on the next URL in the sequence. In the event no match is found (the album didn't chart that week, or BB returned a wonky table), the corresponding cell should be left blank. The macro should exit once the list of URLs is exhausted.
My problem is twofold: first off, is my thought process regarding the macro fundamentally sound? And second-but-most-importantly, I haven't the faintest clue where to even start writing this in VBA. I have studied Java, C, and most recently C++ (OpenGL, specifically). I'm totally unfamiliar with the VBA syntax and API, and frankly, my time on this is far too short to sit down and formally learn the language. After this, I plan on doing so in short order, but this assignment is due Monday and I had no idea how massive an undertaking it was going to end up being.
FOR THE RECORD, the macro is not the assignment, but the data to be collected is integral to completing it. To those curious, the assignment is to produce a complete rough draft of my senior thesis by Monday. This data will be used to create several graphs that my advisors have instructed me to include with my writing. The paper itself is already written based on simply reading each album's sales performance off the site.
You'd be helping me go above-and-beyond, as most of the other graduating seniors are turning in some seriously half-baked graphical representation. The only other student that went this far invented an instrument and provided schematics and autoCAD drawings. However, on that I digress.
Thanks in advance for the help!!
I think this should get you about 90%. The only thing this won't do is the web query.
For that part, I propose that you use the macro recorder to do a web query, and then post that code in a revision and we'll add it in and tailor it to your needs. You've gotta do some work on this :)
Option Explicit
Sub TestMacro()
Dim inputVal As String
Dim artistCell As Range
Dim artistName As String
Dim albumCell As Range
Dim albumName As String
Dim ws As Worksheet: Set ws = Sheets("thesisData")
Dim r As Long 'this will be our row iterator variable
Dim hLink As String 'string for each hyperlink in the iteration
Dim wsNew As Worksheet 'this will be used when we create new worksheets
Dim foundRange As Range 'this is how we will locate the album
Dim weekRank As Long 'weekly rank from column C
On Error GoTo InvalidRange 'This error handling is for the input box, to trap invalid arguments.'
'Use an input box to capture the cell address'
inputVal = InputBox("Please enter the cell location containing the ARTIST name", "Input Range")
Set artistCell = Range(inputVal) 'set a Range variable for the artist'
artistName = artistCell.Value 'string variable for artist name'
inputVal = vbNullString 'clear out the inputVal'
'Use an input box again...'
inputVal = InputBox("Please enter the cell location containing the ALBUM name", "Input Range")
Set albumCell = Range(inputVal) 'set a Range variable for the song cell'
albumName = albumCell.Value 'string for song name'
On Error GoTo 0
For r = 3 To 608 'iterate over rows 3 to 608
hLink = ws.Cells(1, r).Value
'Add a new sheet after the last sheet in this file'
Set wsNew = Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
wsNew.Name = Format(ws.Cells(r, 2).Value, "YYYY-MM-DD")
'''' add VBA for web query, here.'
''''
'''' try using the macro recorder and we can tweak it to your needs.'
''''
''''
''''
'Rather than looping over all the cells in web query...'
Do
'Use the FIND method to look for matching album title in column D.'
' this uses exact text match, non-case-sensitive.
Dim fnd
Set foundRange = wsNew.Columns(4).Find(What:=albumName, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not foundRange Is Nothing Then
'if we've found a match, then just offset by 1 row and check against artist name'
If foundRange.Offset(1, 0) = artistName Then
'likewise, just offset the foundRange cell by -1 columns to get the weekly rank'
weekRank = foundRange.Offset(0, -1)
'At this point I'm not sure what cell you want to put this value in, '
' but I think you want row designated by "r" and the column of the '
' album name, so we can do that like this:
ws.Cells(r, albumCell.Column).Value = weekRank
End If
End If
Loop While Not foundRange Is Nothing
Next
Exit Sub 'before error handling
InvalidRange: 'error handling
MsgBox inputVal & " is not a valid range", vbCritical, "Error!"
End Sub
Good luck!
Edit this also assumes that there is only going to be one match in each web query. In the event there is more than one, it would only return the last match. That seems like a safe assumption given the nature of the data, but if that's not the case, let me know and I can tweak it.