Create in VBA a kind of Object Slider

May 4, 2017, 8:10 am

≫ Next: MsOf365 Unable to get the Norm_Inv property of the WorksheetFunction Class

≪ Previous: MsOf10 Run Time Error 52 Using Dir()

$

0

0

Hello to All my name is A.Maurizio.
And my problem is this: On a spreadsheet of Excel i have inserted 5 objects classified as (Oval 1, Oval 2) etc ...!

Now my intent would be to create a kind of Slaider as it did in Windows XP when the operating system was loaded into the PC.

With the only variant I would like the thing to work according to a predetermined logic of the end user.

Let me explain better: I wish that when I insert a number that may range from (1 to 10) in cell "B1" of Excel sheet; Then I press the start button.

These Objects could change color alternately by scanning time.
For example :

Switch from Base (Gray) to Color (Yellow) to give the feeling of On and Off, and so on with all the others until the end of the cycle that is determined by the numbers entered in Cell (B1).
For here: If I enter (B1) the number 2 the cycle will have to do 2 laps; While I insert 10, The loop will have to do 10 scans, etc. ...!
That's all.

Thank you for all the help you will give me about Greetings and Thank you by A.Maurizio

(P.S) I also insert my Project, so it is not so I want it

Attached Files

• Slider Ad Oggetti.zip (29.5 KB)

---

MsOf365 Unable to get the Norm_Inv property of the WorksheetFunction Class

May 4, 2017, 9:50 am

≫ Next: sendkeys from Excel to Outlook

≪ Previous: Create in VBA a kind of Object Slider

$

0

0

Hey all,

I'm currently running the chunk of code below, and when attempting to produce a random number I'm receiving the "unable to get the Norm_inv property of the WorksheetFunction class". I've had this error crop up on other occasions where I'm using Norm_inv, but it occurs extremely rarely, and I use the function thousands of times every iteration of my loop. The Butterflies array is a Double, hence the need for rounding. Does anyone have any clue what is going wrong?

Code:

---

                                    If Butterflies(CurrentBut, 4) = 1 Then
                                        Butterflies(CurrentBut, 7) = Application.WorksheetFunction.Norm_Inv(Rnd(), 38, 2)
                                        Butterflies(CurrentBut, 7) = Round(Butterflies(CurrentBut, 7), 0)
                                    End If
                                   
                                    Butterflies(CurrentBut, 9) = Application.WorksheetFunction.Norm_Inv(Rnd(), 76, 16)
                                    Butterflies(CurrentBut, 9) = Round(Butterflies(CurrentBut, 9), 0)

---

sendkeys from Excel to Outlook

May 4, 2017, 3:38 pm

≫ Next: [RESOLVED] Write to Excel from PPT (Test) to specific username

≪ Previous: MsOf365 Unable to get the Norm_Inv property of the WorksheetFunction Class

$

0

0

Currently tasked with monitoring a group mailbox for specific subjects. While I can loop through the folder in VBA and look at each mailitem there are over 35,000 mail items and it takes hours to process. I note however, that I can manually enter CTRL-A, CTRL-C and paste the list into an Excel sheet in under two minutes.

I have tried creating the Outlook mail app and setting a folder in VBA but can't get a handle on how to use sendkeys "{^A}" from the Excel app to the Outlook object.

Any ideas greatly appreciated.

Regards,
vb1der

[RESOLVED] Write to Excel from PPT (Test) to specific username

May 6, 2017, 2:05 am

≫ Next: WinHttpRequest and Excel 2016

≪ Previous: sendkeys from Excel to Outlook

$

0

0

Hi all
I am new to VB and every step is a battle. I need to launch this project very soon and now I battle with this.

I am busy creating tests in PowerPoint and need to export the results to a specific username

The code for the message boxes look like this:
Dim grade As String
Dim username As String
Dim numberCorrect As Integer
Dim numberWrong As Integer

Sub YourName()
username = InputBox(prompt:="Name and Surname")
grade = InputBox(prompt:="Grade - only the number")
MsgBox " Get Ready to begin " + username, vbApplicationModal, " Shapes/Vorms "
End Sub

After the test has been done, the results need to be exported to Excel but it is not working
The code for that:

Sub SaveToExcel() 'ADDED
Dim oXLApp As Object
Dim oWb As Object
Dim row As Long

Set oXLApp = CreateObject("Excel.Application")

Set oWb = oXLApp.Workbooks.Open("C:\Tests\Username.xlsx")

How do I fix this as I want every child to have their own file containing the results for all the tests?

I truly hope someone can help me soon

WinHttpRequest and Excel 2016

May 7, 2017, 10:55 am

≫ Next: MsOf10 VBA - remove bar chart outlines

≪ Previous: [RESOLVED] Write to Excel from PPT (Test) to specific username

$

0

0

I am having trouble getting the WinHttpRequest to work with Excel VBA. Here is my code:

Code:

---

Private Function RequestWebData(ByVal strURL As String) As String

  '...requires a reference to "Microsoft WinHTTP Services, version 5.1"

  '...strURL is the URL of the target webpage, for example:
  '  https://finance.yahoo.com/quote/MON?p=MON
 
  On Error GoTo PROC_ERR
 
  Dim strWebData As String
  Dim objWReq As New WinHttp.WinHttpRequest
 
  With objWReq
    .Open "GET", strURL, True
    .send
    .WaitForResponse
    strWebData = .responseText
  End With
 
  RequestWebData = strWebData
 
PROC_EXIT:
  On Error Resume Next
  objWReq = Nothing
  Exit Function
 
PROC_ERR:
  Select Case Err.Number
    Case Else
      MsgBox "Error #" & Err.Number & vbCrLf & _
      Chr(34) & Err.Description & Chr(34), vbOKOnly + vbCritical, "RequestWebData"
  End Select
 
  Resume PROC_EXIT

End Function

---

When the code runs and gets to the highlighted line (.WaitForResponse), it raises the following error:



Any helpful suggestions would be very much appreciated.

Attached Images

 

MsOf10 VBA - remove bar chart outlines

May 8, 2017, 6:52 am

≫ Next: Fill Color in cells based on blank cell in column D

≪ Previous: WinHttpRequest and Excel 2016

$

0

0

Hi all,

for all my excel charts, I am looking to set the following rules:

Format chart area > border colour > No fill

My issue is that I have charts that have a set 'solid line' around my bar charts. I am looking for a VBA script that will help remove this border on all my charts

your help is much appreciated.

Fill Color in cells based on blank cell in column D

May 8, 2017, 7:58 am

≫ Next: Runtime Error 1004

≪ Previous: MsOf10 VBA - remove bar chart outlines

$

0

0

Hi...I have a big spreadsheet. The data is imported from another reporting tool so all the formatting is lost. What I would like is to fill color in yellow for the cells in columns K, L and M where the cell in column D is blank and also make the text in bold.
Can someone please help me with the code for this.

Thanks

Runtime Error 1004

May 9, 2017, 12:45 pm

≫ Next: Adding a scrollbar to Excel bank register!

≪ Previous: Fill Color in cells based on blank cell in column D

$

0

0

Hi All,

Having an issue in a report tool that I did not create, but I have to fix ASAP.

Getting Run time Error 1004

the line that is breaking has 'find the 'employee Name' column in it.

intCol = Application.WorksheetFunction.Match(tblSrc.ListColumns(3) _ .Name, dstBook.Sheets(rng.Value) .Rows(tblTop),0)

Can someone help?

---

Adding a scrollbar to Excel bank register!

May 9, 2017, 1:21 pm

≫ Next: Copying filtered data from a pivot table and pasting it into a new workbook

≪ Previous: Runtime Error 1004

$

0

0

I am trying to add a scroll bar to a table in a spreadsheet but I don't know Visual Basic.
I viewed several videos on youtube that insert a scrollbar into a table but every one of
them was designed to pull data from a different table. That is NOT what I want! I want
the table to scroll after fifteen entries fill up my check register!

Can someone help me with this, please?

Much appreciated!

Meco

Copying filtered data from a pivot table and pasting it into a new workbook

May 9, 2017, 2:53 pm

≫ Next: MsOf13 VBS to contatenate two cells in a table for email signature

≪ Previous: Adding a scrollbar to Excel bank register!

$

0

0

Hi everyone!

New member here. Recently, I started a new role with a big bank in NYC and it requires some serious VBA coding, which I have some experience in, but not at the level they need. With that being said, I look forward to learning here and contributing to other members as I progress.

Now my question:

I have a filtered pivot table that I need to extract certain information and save it into a new workbook. I need to do this with several lines of business.

I created the pivot table and then I'm using a slicer to the exact data I need. This sliced data so what I need to copy and paste into a new workbook. However, it doesn't copy the underlying data, only the cells that are visible.

How can I go about copy the underlying data as well? Also, is there a better way to filter the data other than using a slicer? The macro I recorded to use the slicer is extremely long.

Much appreciate!

G

MsOf13 VBS to contatenate two cells in a table for email signature

May 10, 2017, 7:31 am

≫ Next: Push Data to Excel using ADODB

≪ Previous: Copying filtered data from a pivot table and pasting it into a new workbook

$

0

0

Hi,

I need a help for a script to concatenate cells in a table for mail signature. I tried the script below but the error occurs 800A0400 Expected statement.

objDocTables(1).Cell(2,1).Merge MergeTo:=objDocTables(1).Cell(2,2)

Or a form of insert a horizontal line and a image above the table.

Push Data to Excel using ADODB

May 10, 2017, 1:11 pm

≫ Next: MsOf13 Need help and simplify the code (newbie)

≪ Previous: MsOf13 VBS to contatenate two cells in a table for email signature

$

0

0

Question 1: Which version of ADODB? 2.8, 6.0, 6.1??

Question 2: I am trying to push data in, and the rs.fields.item("fieldname")=string variable seems to be the wrong syntax.

See attached pic.




Much thanks in advance!

Attached Images

 

MsOf13 Need help and simplify the code (newbie)

May 11, 2017, 2:23 am

≫ Next: [Outlook 2007] Macro not working with IPM.POST

≪ Previous: Push Data to Excel using ADODB

$

0

0

Sub generate()

Dim timeStart As Date, timeEnd As Date, dateDate As Date, dS As Date, dE As Date
Dim lastRow As Long, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastCol As Long
Dim Firstrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim i As Long
Dim r As Long, lr As Long
Dim intA As Integer
Dim wrksht As Excel.Worksheet
Dim Aname As String
timeStart = Now()


Sheets("Episodes").Select
Sheets("target").Visible = True
Sheets("Episodes").Select
Sheets("roster").Visible = True

Set wrksht = Application.Worksheets("source")
intA = 1

Do Until intA = wrksht.UsedRange.Rows.Count

Select Case wrksht.Cells(intA, "O").Value
Case "OPEN", "OPEN - New", "OPEN-MD Review", "OPEN-PENDING", "OPEN-PENDING ACTIVITY", "OPEN-Transfer", "CLOSED BY ONSHORE", "VOID - INVALID-Rework"
wrksht.Rows(intA).Delete

Case Else
intA = intA + 1

End Select

Loop


Sheets("target").Select
Cells.Select
Selection.ClearContents

Set sheet1 = Worksheets("source")
Set sheet2 = Worksheets("target")
lastRow = sheet1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lastRow
erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
sheet2.Cells(erow, 1) = sheet1.Cells(i, 1) 'Episode_Number
sheet2.Cells(erow, 2) = sheet1.Cells(i, 2) 'SR_Number
sheet2.Cells(erow, 3) = sheet1.Cells(i, 4) 'CTS_DueDate
sheet2.Cells(erow, 4) = sheet1.Cells(i, 6) 'Request_Received_Date
sheet2.Cells(erow, 5) = sheet1.Cells(i, 7) 'FB_Age
sheet2.Cells(erow, 6) = sheet1.Cells(i, 8) 'Group_Name
sheet2.Cells(erow, 7) = sheet1.Cells(i, 9) 'Reason for Referral
sheet2.Cells(erow, 8) = sheet1.Cells(i, 11) 'Client Group
sheet2.Cells(erow, 9) = sheet1.Cells(i, 12) 'DueDate_Day
sheet2.Cells(erow, 10) = sheet1.Cells(i, 13) 'Allocated To
sheet2.Cells(erow, 11) = sheet1.Cells(i, 14) 'Allocated Date
sheet2.Cells(erow, 12) = sheet1.Cells(i, 15) 'Status
sheet2.Cells(erow, 13) = sheet1.Cells(i, 16) 'GBK Code
sheet2.Cells(erow, 14) = sheet1.Cells(i, 18) 'Last Updated Date
sheet2.Cells(erow, 15) = sheet1.Cells(i, 19) 'Uploaded Date

Next i

Columns("K:K").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("J:J").Select
Selection.TextToColumns Destination:=Range("J1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(9, 1)), TrailingMinusNumbers:=True
'Columns("K:K").Select

Columns("J:J").Select
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'-----
' inserts a new column and delimit
Columns("M:M").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("L:L").Select
Selection.TextToColumns Destination:=Range("L1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(11, 1)), TrailingMinusNumbers:=True

' converts to date
Columns("L:L").Select
Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True

Columns("Q:Q").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("P:P").Select
Selection.TextToColumns Destination:=Range("P1"), DataType:=xlFixedWidth, _
OtherChar:=",", FieldInfo:=Array(Array(0, 1), Array(12, 1)), _
TrailingMinusNumbers:=True
Selection.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True

Columns("R:R").Select
Selection.TextToColumns Destination:=Range("R1"), DataType:=xlFixedWidth, _
OtherChar:=",", FieldInfo:=Array(Array(0, 1), Array(12, 1)), _
TrailingMinusNumbers:=True
Selection.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
:=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True
'
' '-------------------stop here
'add headers
Range("A1").Select
ActiveCell.FormulaR1C1 = "Episode Number"
Range("B1").Select
ActiveCell.FormulaR1C1 = "SR Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "CTS Due Date"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Request Received Data"
Range("E1").Select
ActiveCell.FormulaR1C1 = "FB Age"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Group Name"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Reason for Referral"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Client Group"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Due Date Day"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Associate ID"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Associates Name"
Range("L1").Select
ActiveCell.FormulaR1C1 = "Allocated Date"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Aloocated Time"
Range("N1").Select
ActiveCell.FormulaR1C1 = "Status"
Range("O1").Select
ActiveCell.FormulaR1C1 = "GBK Code"
Range("P1").Select
ActiveCell.FormulaR1C1 = "Last Updated Date"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "Total Work"
Range("R1").Select
ActiveCell.FormulaR1C1 = "Uploaded Date"
Range("S1").Select
ActiveCell.FormulaR1C1 = "Uploaded Time"
Range("T1").Select
ActiveCell.FormulaR1C1 = "Project Manager"
Range("U1").Select
ActiveCell.FormulaR1C1 = "Ops Manager"
Range("V1").Select
ActiveCell.FormulaR1C1 = "CLOSED-Overturned"
Range("W1").Select
ActiveCell.FormulaR1C1 = "CLOSED-Upheld"
Range("X1").Select
ActiveCell.FormulaR1C1 = "CLOSED-MD Approved"
Range("Y1").Select
ActiveCell.FormulaR1C1 = "VOID-Duplicate"
Range("Z1").Select
ActiveCell.FormulaR1C1 = "VOID-Already Paid"
Range("AA1").Select
ActiveCell.FormulaR1C1 = "VOID-Misroute"
Range("AB1").Select
ActiveCell.FormulaR1C1 = "Productivity"
'---- deletes the row 2 header
Rows("2:2").Select
Selection.Delete Shift:=xlUp
'
' '----- stops here for vlookup associates and project manager
Range("T2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-10],roster!C[-19]:C[-16],4,0)"
Range("T2").Select
Selection.AutoFill Destination:=Range("T2:T30000")
Range("T2:T30000").Select
Range("V4").Select
'---- vlookup completed
'--- paste values

'computation here ---
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("V2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-8]=R1C,""1"",""0"")"
Range("W2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-9]=R1C,""1"",""0"")"
Range("X2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-10]=R1C,""1"",""0"")"
Range("Y2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-11]=R1C,"".25"",""0"")"
Range("Z2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-12]=R1C,"".25"",""0"")"
Range("AA2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-13]=R1C,"".25"",""0"")"
Range("AB2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-6]:RC[-1])"
Selection.NumberFormat = "0.00"


'autofill to down
Range("V2:AB2").Select
Selection.AutoFill Destination:=Range("V2:AB15000")
Selection.NumberFormat = "0.00"
Range("V2:AB15000").Select


Range("V2:AA2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Range("V2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Dim LastRow As Integer, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet
'Delete Preivous Pivot Table Worksheet & Insert a New Blank Worksheet With Same Name
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Episodes").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Episodes"
Application.DisplayAlerts = True
Set PSheet = Worksheets("Episodes")
Set DSheet = Worksheets("target")
'
'
'Define Data Range
lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol)

'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="Episodes")


'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable_
'(TableDestination:=PSheet.Cells(1, 1), TableName:="SalesPivotTable")

'Insert Row Fields -------------------------------------------

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"target!R1C1:R18000C21", Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:="Episodes!R3C1", TableName:="Episodes", DefaultVersion _
:=xlPivotTableVersion15
Sheets("Episodes").Select
Cells(3, 1).Select


With ActiveSheet.PivotTables("Episodes").PivotFields("Project Manager")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("Episodes").PivotFields("Associates Name")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
"Episodes").PivotFields("Total Work"), "Count of Total Work", xlCount
'\\\\\
' With ActiveSheet.PivotTables("Episodes").PivotFields("Sum of Total Work")
' .Caption = "Count of Total Work"
' .Function = xlCount
' End With
'\\\\
With ActiveSheet.PivotTables("Episodes").PivotFields("Sum of Total Work")
.Caption = "Count of Total Work"
.Function = xlCount
End With


ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
"Episodes").PivotFields("Productivity"), "Count of Productivity", xlCount
With ActiveSheet.PivotTables("Episodes").PivotFields("Count of Productivity")
.Caption = "'Productivity"
.Function = xlSum
End With

With ActiveSheet.PivotTables("Episodes").PivotFields("Status")
.Orientation = xlRowField
.Position = 3
End With
With ActiveSheet.PivotTables("Episodes").PivotFields("Last Updated Date")
.Orientation = xlColumnField
.Position = 1
End With

With ActiveSheet.PivotTables("Episodes").PivotFields("Client Group")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("Episodes").PivotFields("FB Age")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("Episodes").PivotFields("Group Name")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("Episodes").PivotFields("Reason for Referral")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("Episodes").PivotFields("GBK Code")
.Orientation = xlPageField
.Position = 1
End With
Range("B3").Select
ActiveSheet.PivotTables("Episodes").CompactLayoutRowHeader = "Associates Name"
Range("C3").Select
ActiveSheet.PivotTables("Episodes").TableStyle2 = "PivotStyleDark7"
Cells.Select



With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With

ActiveWindow.DisplayGridlines = False
Range("A4").Select
ActiveSheet.PivotTables("Episodes").CompactLayoutRowHeader = _
"Associates Name"
Range("C3").Select

ActiveWorkbook.ShowPivotTableFieldList = False
Range("F5").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 85
Cells.Select


Sheets("source").Select
Application.CutCopyMode = False
Selection.ClearContents
Sheets("Episodes").Select
Cells.EntireColumn.AutoFit

Sheets("target").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("roster").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("source").Select
ActiveWindow.SelectedSheets.Visible = False
'create a workbook
Episodes = ActiveWorkbook.Sheets(1).Range("A1").Value
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Episodes & ".xls"


timeEnd = Now()
MsgBox ("Completed in " & Format(timeEnd - timeStart, "hh:mm:ss") & ".")


End Sub

[Outlook 2007] Macro not working with IPM.POST

May 11, 2017, 9:53 am

≫ Next: Associate the Zodiac with Your Day Horoscope Extract from an Internet Page in VBA

≪ Previous: MsOf13 Need help and simplify the code (newbie)

$

0

0

Good Afternoon,

I am using a macro on a public folder for a department at my company. The macro is intended to strip the attachments from a message, save the attachments in a specific location, and provide a link to the location inside the body of the message. I am having a few issues that I cannot resolve on my own. I've scoured the internet before posting here, so I'm hoping that my request is even possible.

1) I cannot figure out how to separate the links when the link is posted into the body of the message. When a mail item has one attachment, the link works fine. However when the mail item has multiple attachments, all the folder locations are entered into the message as one long path (Example: The file(s) were saved to I:\Parts Dept\Email Retention\OLAttachments\Bill George.2017-05-08 13-36-46.0471843-DM.pdfI:\Parts Dept\Email Retention\OLAttachments\Bill George.2017-05-08 13-36-46.0471843.pdfI:\Parts Dept\Email Retention\OLAttachments\Bill George.2017-05-08 13-36-46.image001.jpg).

2) As I stated, I am using this in a public folder. This macro is working when used on regular messages in the public folder, however the majority of the items in the folder are actually postings (IPM.Post). The macro fails when being ran on any of the posts. This is the only reason I can find for why the macro is not working, but I'm not sure how to fix it and internet searches have been unsuccessful.

3) This macro was working successfully on mail messages, but when I tried running it about an hour or so later, it gave a "Compile Error: Variable not defined." for the "invalidChars" in the macro. I'm not sure why this suddenly stopped working.

Any assistance with this would be greatly appreciated! I have posted the macro below. (FYI - This was not originally created by me. I have limited exposure to VBA (mostly excel) so I have only made a few changes such as folder path.)

Code:

---

Public Sub StripAttachments_Explorer()
'This VBA Macro removes attachments from whatever emails are selected
'in the Outlook explorer window and stores them on the hard drive.  Links
'to the stored files are added to the email.  Note that RTF and PlainText
'messages are converted to HTML.  The hooks are still below if you want to
'uncomment those line and handle text messages separately.
'Tested with Outlook 2003 only.
'v1.3, Carl C, 22-Feb-09
'http://manage-this.com
'
On Error GoTo ErrorHandler
'
'Edit this path to point to the root for your archive. This
'folder must already exist before for you start using this tool.
'Choose a root folder that is easy to remember for restoring
'message attachments later since the message bodies will be
'written with hard links to this location.
Const RootFolder = "I:\Service\Dan Emanuelson\Email Retention\2017\"
'
'Threshold message size (in kilobytes) - Messages smaller than this get skipped.
Const THRESH As Long = 50 'kb
'
Dim olns As Outlook.NameSpace
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelectedItems As Outlook.Selection
Dim i, J, Counter As Integer
Dim msgFormat As Long
Dim Header, FileList, Footer As String
Dim attPath, attFileName, msgFolder, msgSender, msgSubject, yearFolder, temp As String
Dim oleFound, dropSubject As Boolean
'
Set olns = Application.GetNamespace("MAPI")
'
Set objSelectedItems = olns.Application.ActiveExplorer.Selection
'
'Make sure base path exists
If Dir(RootFolder, vbDirectory) = "" Then
    MsgBox "Root Folder Not Found!" & vbCrLf & _
    "Please create the following folder first: " & vbCrLf & RootFolder
    GoTo ExitSub
End If
'
For Each objMsg In objSelectedItems
'
' Skip anything that's not a mail message (calendar items, tasks, etc.)
If objMsg.Class = olMail Then
'
Set objAttachments = objMsg.Attachments
Counter = objAttachments.Count
'
'Only execute if there is at least one attachment in the message
If Counter > 0 Then
'
'Check if the attachments have already been removed - if so, don't do it again
If objAttachments.Item(1).Type <> olOLE Then
    If (objAttachments.Item(1).FileName = "Attachments Removed") _
            And (Counter = 1) Then
        GoTo TheNextMessage
    End If
End If
'
'If the current message is fairly small, then skip it.  It likely containts only
'tiny pics in the signature or a background image. No point in stripping those.
'Note - It would be better to check the size of each attachment, but there is no
'clean way to do this in Outlook 2003. Would require PR_ATTACH_SIZE (0x0E200003)
'property of the attachment... See http://www.cdolive.com/cdo10.htm
If (objMsg.Size < (1024 * THRESH)) Then
    GoTo TheNextMessage
End If
'
'Check to see if any of the attachments are OLE format.  If so, skip the
'entire message since stripping these is messy
oleFound = False
For i = objAttachments.Count To 1 Step -1
    If objAttachments.Item(i).Type = olOLE Then
        oleFound = True
        Exit For
    End If
Next i
If oleFound Then GoTo TheNextMessage
'
'Note - I disabled the year folder since it had to be checked for every
'message.  Added it to the Root Path definition instead.
'
'Create the year folder if it doesn't already exist
'yearFolder = RootFolder & Strings.Format(objMsg.ReceivedTime, "yyyy") & "\\"
'If Dir(yearFolder, vbDirectory) = "" Then
'    MkDir (yearFolder)
'End If
'
'Some of the dual-byte (DBCS) chars cause problems since the subject line is
'used in the file path name.  If the message format does not belong to one of
'the formats below, then don't use the subject line in the path or file name.
dropSubject = False
msgFormat = objMsg.InternetCodepage
If ((msgFormat = 28592) Or (msgFormat = 1250) Or (msgFormat = 20127) _
    Or (msgFormat = 28591) Or (msgFormat = 1252)) Then
    msgSubject = objMsg.Subject
Else
    msgSubject = "message"
    dropSubject = True
End If
'
'Strip illegal chars from msgSubject
invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "…")
For J = LBound(invalidChars) To UBound(invalidChars)
    temp = Replace(msgSubject, invalidChars(J), " ")
    msgSubject = temp
    temp = Replace(msgSubject, invalidChars(J), " ")
    msgSubject = temp
Next J
msgSubject = Replace(msgSubject, "RE ", "")
msgSubject = Replace(msgSubject, "FW ", "")
msgSubject = Trim(msgSubject)
If objMsg.Subject = "" Then msgSubject = "no subject"
'
'Derive a short form of the Sender Name...
'If your company adds text to your display names then modify
'these lines to clean it out when creating the folder names
msgSender = Replace(objMsg.SenderName, " (YourCompanyName, consultant)", "")
msgSender = Replace(msgSender, " (YourCompanyName)", "")
'
'Create the Folder/Path name for the attachments
If (dropSubject) Then
    msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") & msgSender
Else
    msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") _
        & msgSender & " - [" & msgSubject & "]"
End If
'msgFolder = yearFolder & msgFolder & "\\"
msgFolder = RootFolder & msgFolder & "\\"
'
'Create the message folder for the individual email attachments
If Dir(msgFolder, vbDirectory) = "" Then
    MkDir (msgFolder)
End If
'
'Save text of message to the attachment folder for reference
objMsg.SaveAs msgFolder & msgSubject & ".txt", olTXT
'
'If objMsg.BodyFormat = olFormatPlain Then
'    Header = "============================================================" _
'        & vbCrLf & "Attachments Archived: " & "<file://" _
'        & Replace(msgFolder, "\\", "\") & ">"
'Else
    Header = "<font face=""Courier New"" size=2 color=#736F6E>" _
        & "============================================================" _
        & "<br><a HREF=""file://" & Replace(msgFolder, "\\", "\") _
        & Chr(34) & ">Attachments Archived:</a>"
'End If
'
FileList = ""
'
'Walk through the attachment collection archiving each one
For i = objAttachments.Count To 1 Step -1
'
attFileName = objAttachments.Item(i).FileName
attPath = msgFolder & "\\" & attFileName
'
' Save the attachment to disk then remove it from the email
objAttachments.Item(i).SaveAsFile attPath
objAttachments.Item(i).Delete
'
' Build up list of links to stored files in FileList string
'If objMsg.BodyFormat = olFormatPlain Then
'    FileList = vbCrLf & "[" & i & "] " & "<file://" _
'        & Replace(attPath, "\\", "\") & ">" & FileList
'Else
    FileList = "<br>" & "[" & i & "] " & "<a REL=ATT_LNK " _
        & "HREF=""file://" & Replace(attPath, "\\", "\") _
        & Chr(34) & ">" & attFileName & "</a>" & FileList
        'Note - the REL=ATT_LNK is for a future enhancement to
        'parse forwarded or re-sent messages and re-attach the files
'End If
'
Next i
'
' display log/links in the message body
'If objMsg.BodyFormat = olFormatPlain Then
'    Footer = vbCrLf & _
'        "============================================================" _
'        & vbCrLf & vbCrLf
'    objMsg.Body = Header & FileList & Footer & objMsg.Body
'Else
    Footer = "<br>" & _
        "============================================================" _
        & "<br><br></font>"
    objMsg.HTMLBody = Header & FileList & Footer & objMsg.HTMLBody
'End If
'
'Attach an empty file to trigger Outlook paperclip icon
'Note - you need to create this ahead of time and place it in a folder
'named "config" inside your root message folder. The file name must be
'as shown below with no .txt suffix
temp = RootFolder & "\\config\\Attachments Removed"
objAttachments.Add temp, olByValue, , "Attachments Removed"
'
objMsg.Save
'
End If  'If Counter > 0 Then
End If  'If objMsg.Class = olMail
'
TheNextMessage:
Next objMsg
'
ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelectedItems = Nothing
    Set olns = Nothing
    Exit Sub
'
ErrorHandler:
  MsgBox "RemoveAttachments( ) Subroutine" & vbCrLf & vbCrLf _
        & "Error Code: " & Err.Number & vbCrLf & Err.Description
  Err.Clear
  GoTo ExitSub
End Sub

---

Associate the Zodiac with Your Day Horoscope Extract from an Internet Page in VBA

May 12, 2017, 8:29 am

≫ Next: CHECK in all workbook opened...

≪ Previous: [Outlook 2007] Macro not working with IPM.POST

$

0

0

Good morning to all my name is A.Maurizio
And my question and this: Time ago I was able to create a program entirely in VBA
Using an Excel sheet, where I was looking for the zodiac sign I wanted through a ComboBox, and then pressing a button I called my Horoscope.
Everything using this Code:

Code:

---

Private Sub Cmd_AvviaOroscopo_Click()
On Error Resume Next
Range("F2").Value = "" & ListBox1.Text
  'vSegno = Target
    vSegno = Range("J2").Value & ""
      Range("F2").Value = "" & Oroscopo(vSegno)
End Sub

---

And then in the Module I wrote this:

Code:

---


Public Function Oroscopo(ByVal vSegno As Variant) As String
  Dim sSource As String
  Dim aSegni As Variant
  Dim j As Integer
  Dim sSegno As String
  Dim nSegno As Integer
  Dim sOroscopo As String
  Dim Http1 As Object
  Dim sUrl As String
  Dim nAtH2 As Long
  Dim nAtP As Long
  Dim nAtCP As Long
  On Error GoTo Oroscopo_Error
 
  aSegni = Split("Ariete Toro Gemelli Cancro Leone Vergine Bilancia Scorpione Sagittario Capricorno Acquario Pesci")
  If IsNumeric(vSegno) Then
    nSegno = vSegno
    sSegno = aSegni(nSegno - 1)
  Else
    sSegno = vSegno
    For j = 0 To 11
      If aSegni(j) = sSegno Then
        nSegno = j + 1
      End If
    Next
  End If
  Set Http1 = CreateObject("MSXML2.XMLHTTP")
 
  sUrl = "http://oroscopo.donnad.it/oroscopo/settimanale/segno/s/" & nSegno
  Http1.Open "GET", sUrl, False
  Http1.Send
  sSource = Http1.ResponseText
  Set Http1 = Nothing
 
  nAtH2 = InStr(1, sSource, "</h2>", vbTextCompare)
  nAtP = InStr(nAtH2, sSource, "<p>", vbTextCompare) + 3
  nAtCP = InStr(nAtP, sSource, "</p>", vbTextCompare) - nAtP
  sOroscopo = VBA.Mid(sSource, nAtP, nAtCP)
  sOroscopo = sSegno & vbCrLf & VBA.Trim(Replace(Replace(Replace(sOroscopo, vbLf, ""), vbCr, ""), vbTab, ""))
 
Oroscopo_Error:
  If Err.Number <> 0 Then
    Set Http1 = Nothing
    sOroscopo = "Non disponibile!"
  End If
  Oroscopo = sOroscopo
End Function

---

Now All That Worked Well Up To Some Years ago; Then nothing happens to me since then.
I also tried to change the Address of the Connected Internet Site, thinking that the page with Time was Expired; But nothing to do.
Here is my question and this: There would not be another way more to view it all without adopting my Criterion.
Thank you for all the help you want to give me, Sincerely greetings from A.Maurizio

(P.S) Anyway For More Information I Insert My Test Project

Attached Files

• Lettura Oroscopo di Prova.zip (37.9 KB)

---

CHECK in all workbook opened...

May 15, 2017, 2:12 am

≫ Next: &H values and Long variable type in Excel VBA

≪ Previous: Associate the Zodiac with Your Day Horoscope Extract from an Internet Page in VBA

$

0

0

i need to CHECK if in all Excel session a workbook named TEST.xls is opened if yes close it without to save...

How to with code in other workbook?

tks.

&H values and Long variable type in Excel VBA

May 15, 2017, 2:14 pm

≫ Next: Resizing OLEObject in word

≪ Previous: CHECK in all workbook opened...

$

0

0

Hi,

I have the following issue in the usage of &H<hex number>

In a procedure in Microsoft Excel VBA:

Dim lngVal as Long

then

lngVal = &H8000

gives a lngval of -32768

it should have given
32768 decimal

since &H7FFF ---> 32767 decimal


Thought that variable Long is a 32bit number.

Any idea?

Resizing OLEObject in word

May 16, 2017, 6:16 am

≫ Next: MsOf10 How to make a VBE Addin for both word and excel using VB6

≪ Previous: &H values and Long variable type in Excel VBA

$

0

0

Hi,

I use the following to paste a visio docuemt into an MS Word page:

Code:

---

objselection.InlineShapes.AddOLEObject _
filename:=visiofilename, _
LinkToFile:=False, _
DisplayAsIcon:=False

---

Works fine but i would like to specify the width as some of the visios are too large and are not fully viewable after insert.

I can across the .scalewidth attribute but cannot seem to get it to work with the above code, any suggestions?

Thank in advance.

Steve

MsOf10 How to make a VBE Addin for both word and excel using VB6

May 17, 2017, 9:23 am

≫ Next: Excel - Compare 2 Data Sets with an anchor column(s) - VB Script help needed

≪ Previous: Resizing OLEObject in word

$

0

0

I know how to make an addin for either word vba VBE or excel vba VBE
but i wonder, can i make a dll for both of them?

Excel - Compare 2 Data Sets with an anchor column(s) - VB Script help needed

May 17, 2017, 12:18 pm

≫ Next: Split Worksheet after each change in column A

≪ Previous: MsOf10 How to make a VBE Addin for both word and excel using VB6

$

0

0

Hi, I am comparing 2 sets of reports (sheet1 & sheet2) with periodic changes. 1st and foremost I need to identify the anchor (column items) that dropped off & added… I have had success by using multi array formula such as the one attached below but it’s taking too long & too manual, and it limits comparison up to 6 columns per worksheet. I have to put the formula in both sheet1 & sheet2 then manually delete (anchor) items that were dropped off or added, then compare each columns individually using vlookup. It’s extremely time consuming but works.

Is there a VB Script or alternative way to comparing data without having to cut & paste columns of data from one sheet to another.
Thanks in advance,
Luke.
________________________________________________
=INDEX(Sheet1!$A$1:$G$3590, MATCH(1,(Sheet2!$A3=Sheet1!$A$1:$A$3590)*(Sheet2!$B3=Sheet1!$B$1:$B$3590)*…….etc.

Example: Per below, note “Name” is the anchor column, changes occurred by week two include 1) Rob dropped off & is replaced by Matt, and 2) Ted is now wearing blue contacts with a change in EyeColor.

Sheet1 (week one)
Name Age BirthPlace EyeColor
John 89 Iceland Blue
Ann 108 England Brown
Ted 56 US Black
Rob 32 US Brown

Sheet2 (week two)
Name Age BirthPlace EyeColor
John 89 Iceland Blue
Ann 108 England Brown
Ted 56 US BLUE
Matt 123 US Brown