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'm having a little trouble understanding how your sheet is laid out, can you attach an example spreadsheet

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]