Posts by chavezm3

    I will try to explain this as clearly and concisly as possible. I have a list that contains unique batches with various attributes. One of thes attributes is a parent batch. The parent batch may or may not be populated, is not necessarily unique, and in no certain order. My end goal is to determine each unique batch that shares a parent batch with any of the other unique batches, and collect some information for those batches. What I want to do is loop through the list and find each parent batch, create a new object of custom class clsParent, and add the unique batch as an object of custom clsChild as a collection of the parent object. The problem I am running into is that once I add a child to the parent, I don't know how to recall that parent at a later time to add another child. I would appreciate any guidance on the matter and can provide additional detail as needed.

    Thanks Ken, that did the trick, I kept skipping over the .Chart member of the chart object but with your aid it is working now.


    I do need a macro as I am building an automated control chart sheet with multiple parameters, while trying to keep it looking tidy.


    Just out of curiosity, why is it called TextFrame2, is there a TextFrame1?

    I have an embedded chart on Sheet1 named "Zn 10" with two custom textboxes on it. What I am trying to do is update the textbox values when the data is altered. I tried searching around the interwebs to figure this out but nothing I've found seems to work. This is all I have so far but it keeps throwing a 483 error "Object doesn't support this property or method" any help would be greatly appreciated.


    [VBA]Sub Macro1()


    Sheet1.ChartObjects("Zn 10").Shapes("Zn UCL").TextFrame.Characters.Text = "test"

    End Sub[/VBA]

    Sorry I misunderstood what you meant. By changing the start of the range from the first cell to the header it now works. I find that odd that it would not search the first cell of the range since it is part of the search area. I tried messing with the after parameter but kept getting that error code of 91.


    thanks for the help NoSparks

    I tried playing with the full settings but kept getting an error code of 91 "Object variable or With block variable not set". Not really sure why since nothing really changed. On another workbook I have basically the same setup but starting at A2 with the same issue. It's almost like it doesn't actually see the 1/1/YY

    I have an odd problem that I have noticed on two worksheets. I have a sheet with dates for the year entered in column A3 and down, starting at 1/1 and going to 12/31. I then have a userform where the user selects a date from a DTPicker and the macro locates the row for the selected date to perform various functions in that row. The problem I have is that when 1/1/YY is selected, the find method always selects the row for date 11/1/YY. I have no idea why it does that and have to manually correct for it ATM. Any insight would be appreciated.


    [VBA]Sub Update_Charts_bydates(DtStart As Date, DtEnd As Date)


    Dim Ws_1 As Worksheet, Ws_2 As Worksheet
    Dim Ch_1 As Chart, Ch_2 As Chart
    Dim rngTATdata As Range, rngTATlabels As Range, rngRFTdata As Range, rngRFTlabels As Range
    Dim iDtEnd As Integer, iDtStart As Integer


    Application.ScreenUpdating = False


    Set Ws_1 = Worksheets("Historical") 'sheet with dates entered down starting at A3
    Set Ch_1 = Charts("TAT")
    Set Ch_2 = Charts("%InSpec")


    Set DateHeader = Ws_1.Range(Ws_1.Range("A3"), Ws_1.Range("A3").End(xlDown)) 'set range to find date


    On Error GoTo ErrHandler
    If Month(DtStart) = 1 And Day(DtStart) = 1 Then '1/1/YY likes to find 11/1/YY instead, so manually correct
    iDtStart = 3
    Else
    iDtStart = DateHeader.Find(DtStart).Row
    End If
    iDtEnd = DateHeader.Find(DtEnd).Row


    '---------------- More code below but not shown
    On Error GoTo 0[/VBA]


    If you really want to see the sheet I can attach a desensitized version upon request

    Try this code to build your To and CC strings, I have the emails in each cell starting at row 2 going down on Sheet14


    [VBA]strTO = Join(Application.Transpose(Sheet14.Range(Sheet14.Range("E2"), Sheet14.Range("E2").End(xlDown)).Value), "; ")
    strCC = Join(Application.Transpose(Sheet14.Range(Sheet14.Range("F2"), Sheet14.Range("F2").End(xlDown)).Value), "; ")[/VBA]


    and then with this for the email code


    [VBA]
    Dim OutlookApp As Variant
    Dim MItem As Variant
    Dim Msg2 As String, strTO As String, strCC As String



    'Create Mail Item and display it
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
    .To = strTO
    .CC = strCC
    .Subject = "Remember to do a PEEP/Ergo Observation"
    .HTMLBody = Msg2
    '.attachments
    .Display
    '.Save 'to Drafts folder
    End With[/VBA]


    this isn't my full code just the relevant parts

    Hi, I'm not sure what you want to do with the end result but I created a procedure in module1 that loops through all the cells in the table and populates the relevant info based on the templaye you created (i created a "Form" sheet to work with). all it does is populates but that should be a start so you can print as pdf or save the templates each time.

    I have this code to grab cell values and add them to a collection and then to name the items by key = their value as a string. This forces an error anytime a duplicate value is encountered since a key must be unique. I basically ignore the error using the [VBA]on error resume next[/VBA]. To sort by date can you not sort the list and then perform an operation such as this?


    [VBA]
    dim Cell as object
    dim Ws_1 as worksheet
    Dim cUnique as New Collection
    Dim vNum As Variant
    dim LastCell as long


    On Error Resume Next
    For Each cell In Ws_1.Range(Ws_1.Range("C2"), Ws_1.Range("C" & LastCell)).SpecialCells(xlCellTypeVisible)
    cUnique.Add cell.Value, CStr(cell.Value)
    Next cell


    For Each vNum In cUnique
    Me.ComboBox4.AddItem vNum
    Next vNum


    On Error GoTo 0
    [/VBA]

    That's because my dumb self forgot to turn the cell reference into a row for the Cells description, i've updated and tested it out, it looks like it works.


    I went with the empty or not because I wasn't sure how many rows would be populated so in order to set the beginning and end of the loop i had to make sure the .End(xlDown) method wouldn't include empty cells. Otherwise it would have gone from the single article, down to the Total line. This is just how I approached it, if you want to try the IsNumeric method I guess you could try a Do Until loop.



    [vba]
    Option Compare Text


    Sub Report_to_Table()


    Dim Cell As Object, Cellb As Object
    Dim Ws_1 As Worksheet, Ws_2 As Worksheet
    Dim LastRwReport As Long, RwStart As Long, RwEnd As Long, NextRwTable As Long
    Dim strPlant As String, strPC As String, strStgLoc As String


    Set Ws_1 = Worksheets("stock ageing")
    Set Ws_2 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create new sheet to build table on


    'find bottom of report output
    LastRwReport = Ws_1.Cells(Rows.Count, "A").End(xlUp).Row


    'bulid new table header
    Ws_1.Range("G9:AF9").Copy Ws_2.Range("H1")
    Ws_1.Range("G11:AF11").Copy Ws_2.Range("H2")
    Ws_2.Range("A2").Value = "Article No"
    Ws_2.Range("B2").Value = "Plant"
    Ws_2.Range("C2").Value = "Profit Centre"
    Ws_2.Range("D2").Value = "Storage Location"
    Ws_2.Range("E2").Value = "Description"



    For Each Cell In Ws_1.Range("A1:A" & LastRwReport)
    If Cell.Value = "423S" Then
    strPlant = Cell.Offset(4, 4).Value
    strPC = Cell.Offset(5, 4).Value
    strStgLoc = Cell.Offset(6, 4).Value


    If Cell.Offset(13, 0).Value <> "" Then 'checks if at least 2 article numbers
    Debug.Print Cell.Offset(12, 0).Row
    RwStart = Cell.Offset(12, 0).Row
    RwEnd = Cell.Offset(12, 0).End(xlDown).Row
    For Each Cellb In Ws_1.Range(Ws_1.Cells(RwStart, 1), Ws_1.Cells(RwEnd, 1))
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cellb.Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cellb.Row, 4), Ws_1.Cells(Cellb.Row, 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    Next Cellb
    Else ' if only one article then just copies the one
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cell.Offset(12, 0).Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cell.Offset(12, 0).Row, 4), Ws_1.Cells(Cell.Offset(12, 0).Row, 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    End If
    End If
    Next Cell


    End Sub
    [/vba]

    maybe I'm just dumb but I don't see the pattern. From what i see i would posit LOOP as another possible option.

    I think this does the trick


    [VBA]Option Compare Text


    Sub Report_to_Table()


    Dim Cell As Object, Cellb As Object
    Dim Ws_1 As Worksheet, Ws_2 As Worksheet
    Dim LastRwReport As Long, RwStart As Long, RwEnd As Long, NextRwTable As Long
    Dim strPlant As String, strPC As String, strStgLoc As String


    Set Ws_1 = Worksheets("stock ageing")
    Set Ws_2 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create new sheet to build table on


    'find bottom of report output
    LastRwReport = Ws_1.Cells(Rows.Count, "A").End(xlUp).Row


    'bulid new table header
    Ws_1.Range("G9:AF9").Copy Ws_2.Range("H1")
    Ws_1.Range("G11:AF11").Copy Ws_2.Range("H2")
    Ws_2.Range("A2").Value = "Article No"
    Ws_2.Range("B2").Value = "Plant"
    Ws_2.Range("C2").Value = "Profit Centre"
    Ws_2.Range("D2").Value = "Storage Location"
    Ws_2.Range("E2").Value = "Description"



    For Each Cell In Ws_1.Range("A1:A" & LastRwReport)
    If Cell.Value = "423S" Then
    strPlant = Cell.Offset(4, 4).Value
    strPC = Cell.Offset(5, 4).Value
    strStgLoc = Cell.Offset(6, 4).Value
    Debug.Print strPlant, strPC, strStgLoc


    If Cell.Offset(13, 0).Value <> "" Then 'checks if at least 2 article numbers
    RwStart = Cell.Offset(12, 0).Row
    RwEnd = Cell.Offset(12, 0).End(xlDown).Row
    For Each Cellb In Ws_1.Range(Ws_1.Cells(RwStart, 1), Ws_1.Cells(RwEnd, 1))
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cellb.Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cellb.Row, 4), Ws_1.Cells(Cellb.Row, 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    Next Cellb
    Else ' if only one article then just copies the one
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cell.Offset(12, 0).Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cell.Offset(12, 0), 3), Ws_1.Cells(Cell.Offset(12, 0), 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    End If
    End If
    Next Cell


    End Sub[/VBA]


    This assumes that article numbers will always appear 12 rows below the "423S", which I assume is the report name. I also wasn't sure if you could ever encounter a data block that only listed one item. I didn't copy the report header over because I wasn't sure if it was important but you should be able to modify the code to do that. I think moving it over to a new sheet cleans it up.

    I know this post is a quite old but I would also like to reaffirm that John Walkenbach's Power Programming with VBA is excellent as a learning tool as well as a reference guide. I have the 2013 version which includes downloadable example files from the authors website. I have borrowed a few of his examples and modified to suit my needs.

    Maybe change the criteria for empty as such. Another caveat would be if there are spaces, I know one of the systems at my work genrates a lot of extra spaces when exporting to excel, thus the cells may look blank but truly have "data" in them. the below recomendation would fail in that instance.


    [VBA]Sub ToDate()
    Dim LR As Long, i As Long
    LR = Range("I" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
    If Cells(i, 2).value <> "" Then


    With Range("I" & i)
    .NumberFormat = "mm/dd/yy"
    .Value = CLng(.Value)


    End With
    End If
    Next i


    End Sub[/VBA]

    I was able to get it working by changing the image names to a fixed name and referenceing them in the email body instead of using the dynamic filename. Still not sure why it didn't like it though. I've cleaned up the code and am posting here if anyone wants to see.


    [VBA]Sub Distribute()


    Dim Ws_1 As Worksheet, Ws_2 As Worksheet
    Dim Dt As Date
    Dim Mt As String, Fname1 As String, Fname2 As String, PDFname As String, FileName As String, strTo As String, _
    FileNm1 As String, FileNm2 As String
    Dim iMt As Integer
    Dim oApp As Outlook.Application
    Dim oEmail As MailItem


    Application.ScreenUpdating = False


    Set oApp = CreateObject("Outlook.Application")
    Set oEmail = oApp.CreateItem(olMailItem)


    Set Ws_1 = Worksheets("Main Dash")
    Set Ws_2 = Worksheets("List")


    Dt = Ws_1.Range("H6").Value


    If Month(Dt) >= 10 Then
    FlNmMonth = Month(Dt)
    Else
    FlNmMonth = "0" & Month(Dt)
    End If
    If Day(Dt) >= 10 Then
    FlNmDay = Day(Dt)
    Else
    FlNmDay = "0" & Day(Dt)
    End If


    FileName = Year(Dt) & "-" & FlNmMonth & "-" & FlNmDay


    PDFname = Environ$("temp") & "\" & "EV KPI Update " & FileName & ".pdf"
    Fname1 = Environ$("temp") & "\" & "InSpec.jpg"
    Fname2 = Environ$("temp") & "\" & "TAT.jpg"


    Charts("%InSpec").Activate
    ActiveChart.Export FileName:=Fname1, filtername:="JPG"


    Charts("TAT").Activate
    ActiveChart.Export FileName:=Fname2, filtername:="JPG"


    'save pdf to temp file for email distribution
    With Ws_1
    Worksheets(Array("Main Dash", "Inorg Dash", "RPM Dash", "Vit Dash", "Micro Dash")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFname, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With


    'build recipient list from email list stored in LIST(J2) down
    For Each Cell In Ws_2.Range(Ws_2.Range("J2"), Ws_2.Range("J2").End(xlDown))
    strTo = strTo & Cell.Value & " ; "
    Next Cell


    msg2 = "<Basefont face = 'Calibri' size = '3'>Please find the KPI dashboard updates for " & FileName & " attached.</font><br><br>"


    'Create Mail Item and display it
    With oEmail
    .To = strTo
    '.CC =
    .Subject = "Evv KPI Update " & FileName
    .Attachments.Add Fname1
    .Attachments.Add Fname2
    .Attachments.Add PDFname
    .HTMLBody = msg2 & "<img src='cid:TAT.jpg' width=750>&nbsp<img src='cid:InSpec.jpg' width=750>"
    .Display
    '.Save
    End With


    Set oEmail = Nothing
    Set oApp = Nothing


    Ws_1.Select


    Kill PDFname
    Kill Fname1
    Kill Fname2


    End Sub
    [/VBA]

    I've been having a problem generating an email and embedding an image in said email. I have used the same code on a different project to accomplish the said goal in the same manner but whenever I try with this sheet I get broken links in the email. The image is a graph housed on a chart sheet (or rather 2 of them). Any help would be greatly appreciated.


    [VBA]Sub Distribute()


    Dim Ws_1 As Worksheet, Ws_2 As Worksheet, Ws_3 As Worksheet, Ws_4 As Worksheet, Ws_5 As Worksheet, _
    Ws_6 As Worksheet
    Dim MainDash As Range, InorgDash As Range, RPMDash As Range, VitDash As Range, MicroDash As Range
    Dim Dt As Date
    Dim Mt As String, Fname1 As String, Fname2 As String, PDFname As String, FileName As String
    Dim iMt As Integer



    Dim oApp As Outlook.Application
    Dim oEmail As MailItem
    Dim colAttach As Outlook.Attachments
    Dim oAttach1 As Outlook.Attachment, oAttach2 As Outlook.Attachment, oAttach3 As Outlook.Attachment


    Set oApp = CreateObject("Outlook.Application")
    Set oEmail = oApp.CreateItem(olMailItem)
    Set colAttach = oEmail.Attachments



    Set Ws_1 = Worksheets("Main Dash")
    Set Ws_2 = Worksheets("Inorg Dash")
    Set Ws_3 = Worksheets("RPM Dash")
    Set Ws_4 = Worksheets("Vit Dash")
    Set Ws_5 = Worksheets("Micro Dash")


    'pulls date of update data
    Dt = Ws_1.Range("H6").Value


    If Month(Dt) >= 10 Then
    FlNmMonth = Month(Dt)
    Else
    FlNmMonth = "0" & Month(Dt)
    End If
    If Day(Dt) >= 10 Then
    FlNmDay = Day(Dt)
    Else
    FlNmDay = "0" & Day(Dt)
    End If


    FileName = Year(Dt) & "-" & FlNmMonth & "-" & FlNmDay
    PDFname = Environ$("temp") & "\" & "EV KPI Update " & FileName & ".pdf"



    'this is the charts being named exported
    Fname1 = "C:\RFT Update " & FileName & ".png"
    Fname2 = "C:\TAT Update " & FileName & ".png"


    Charts("RFT").Activate
    ActiveChart.Export FileName:=Fname1, filtername:="PNG"
    Charts("TAT").Activate
    ActiveChart.Export FileName:=Fname2, filtername:="GIF"


    Set oAttach1 = colAttach.Add(Fname1)
    Set oAttach2 = colAttach.Add(Fname2)



    'save pdf to temp file for email distribution
    With Ws_1
    Worksheets(Array("Main Dash", "Inorg Dash", "RPM Dash", "Vit Dash", "Micro Dash")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFname, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With

    Set oAttach3 = colAttach.Add(PDFname)
    oEmail.Close olSave


    'Create Mail Item and display it
    With oEmail
    .To = "[email protected]"
    '.CC =
    .Subject = "Evv KPI Update " & FileName
    .HTMLBody = "<Basefont face = 'Calibri' size = '3'>Please find the KPI dashboard updates for " & FileName & " attached.</font>" _
    & "<br><br><img src='cid:RFT Update " & FileName & ".png' width=400></img>" & "<br><img src='cid:TAT Update " & FileName & ".gif' width=400></img>"
    .Display
    '.Save
    End With


    Set oEmail = Nothing
    Set colAttach = Nothing
    Set oAttach1 = Nothing
    Set oAttach2 = Nothing
    Set oAttach3 = Nothing
    Set oApp = Nothing



    Ws_1.Select


    Kill PDFname
    Kill Fname1
    Kill Fname2


    End Sub[/VBA]