Quantcast
Channel: VBForums - Office Development
Viewing all 4673 articles
Browse latest View live
↧

Split Worksheet after each change in column A

May 17, 2017, 1:01 pm
$
0
0
Hi I have a large spreadsheet with headings in row 1. In column A are the product codes so for example in row 2 it might say ABC123 then there may be say 10 rows of data and in the other rows column A will be blank. Then in row 12 it may say BCD456 and so many rows of data etc.
What I need to do is at each change in row A I want a new tab creating with the data and want the headings from row 1 copying across. I would like tab name to be the product code for each of the tabs.

The next step is then to split out these tabs into separate workbooks and saved in a particular directory. The filename should be the tab name like ABC123, BCD456 etc.

Would appreciate some help with this please. Thanks
↧
Search

ImageControl Brightness propertie on Excel Worksheet

May 17, 2017, 7:29 am
$
0
0
Hi,

i want get and change the Brightness propertie of picture on ImageControl on Excel Worksheet.
i am not want use setpixel or getpixel simple change of colors, but the properties of colors of picture.
or using color constants Declarations.

i know here not is forum of Microsoft Office but it is more graphics programming hardcore and VB programmers more advanced knowledge about this.

please patience.

thank you.
↧
↧

Add-ins don't work (Excel)

May 18, 2017, 4:01 am
$
0
0
Hello.

I got a problem with two add-ins on Microsoft Excel 2013 (32 bits).

I receive the next messages when i try use them:

Add-in 1:

Name: Sin título.jpg Views: 43 Size: 22.0 KB

Add-in 2:

Name: Sin título2.jpg Views: 35 Size: 13.3 KB


I know how to discover the add-in code (Visual Basic: Alt+11), but i'm not the programmer , so i can't understand the lines.

Can someone help me with this issue? I have no idea. Apparentely, the add-ins are in the right path.
Attached Images
  
↧

[RESOLVED] [Outlook 2007] Macro not working with IPM.POST

May 11, 2017, 9:53 am
$
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
↧

having google execute a google search

May 18, 2017, 5:23 pm
$
0
0
Hi all:

First, a disclaimer. I'm new to this forum and VBA so if I post wrong or something, I apologize.

So I am trying to code a macro that pulls up internet explorer, and executes a google search. But I keep getting the error, "Method 'Document' of object "IWebBrowser2' failed" with the following code:
___________________________________________________________
Sub CustomLoadFromIE()

Dim ie As Object
Set ie = CreateObject("internetexplorer.application")

With ie
.Visible = True
.navigate "www.google.com"

While Not .readystate = readystate_complete
Wend
End With

Var = "whatever I want to search"
ie.Document.getElementbyid("lst-ib").Value = Var

End Sub

__________________________________________________________
What I thought was wrong (which I guess isn't the case?) was the ID of the text box I am attempting to select and put text in for a search, but upon further inspection that appears to be correct.

Any suggestions??
Thank you in advance!!
↧
↧

Using VBA in Excel to print to Brother Label Printer

May 19, 2017, 2:09 pm
$
0
0
Hi all...

Crazy problem here. I have a new QL-700 label printer that purports to allow printing from VBA, .Net and such... and comes with example files.

Running from Excel, their example code never works... at least not right off.

They have two versions of the SDK... 32 and 64 bit.

I got it to work finally on my Win 10 machine with Excel 2016 (Pro Plus)... by adding what they call the "Client Component"... which seems to point toward a Reference: "Brother b-PAC 3.1 Type Library".

The Component appears to install the 32 bit version of the libraries, because they are stored under the Program Files (x86) structure.

The SDK (which needs to be the 64 bit version) also must be installed, and lives under the Program Files structure.



Things get ugly when I try to move this to a Windows 7 Machine... and Excel 2010.

It simply refuses to work... and fails silently, even using the Brother example code.

One issue may be that for some reason, the 64 bit SDK ALWAYS asserts itself over the 32 bit version that comes with the Client Component. Even when I see the Client Component in the References list in the x86 installation, selecting it in the VBA IDE magically transforms it into the 64 bit install.

Perhaps it's a conflict between a 64 bit OS, and a 32 bit Excel?

I have no idea what to do at this point... I don't really understand it much.

Hours of Google searches have yielded no working solutions.

Any thoughts / ideas greatly appreciated.
↧

Run Time Error 1004 application defined object defined

May 22, 2017, 4:25 am
$
0
0
I am using the following code to only display dates between a start date and end date

Code:
Public Sub MyFilter()
    Dim lngStart As Long, lngEnd As Long
    lngStart = Range("Hidden!O31").Value 'assume this is the start date
    lngEnd = Range("Hidden!O32").Value 'assume this is the end date
    Range("I15:ARR15").AutoFilter field:=1, _
        Criteria1:=">=" & lngStart, _
        Operator:=xlAnd, _
        Criteria2:="<=" & lngEnd
End Sub
Bu I am coming up with an error Run Time Error 1004 application defined object defined error, I think it may be because I am taking the start date and end date from another sheet but that would be just a guess any ideas
↧

Problmes with #VALUE in VBA Function

May 22, 2017, 4:54 am
$
0
0
HI all,

I have the following user definde function. The idea is cell contains any of a value list. (Like FIND, but with a list):

Code:
Public Function FINDS(cells_range As Range, find_in As Range) As Boolean
Application.Calculation = xlCalculationAutomatic
Application.Volatile True
Dim value As Boolean
Dim micell As Range

valor = False

For Each micell In cells_range
    If WorksheetFunction.IsError(WorksheetFunction.Search(micelda.value, find_in, 1)) = False Then
        valor = True
        GoTo etiqueta
    End If
Next micelda

etiqueta:
FINDS = value

End Function
The problem appears when Worksheet.Function.Seach returns a #VALUE, cause all VBA Function returns #VALUE.

Any help?
↧
Search

MsOf10 Is ContentControl part of a group

May 22, 2017, 10:40 am
$
0
0
Using VBA, is it possible to determine if a particular Word ContentControl is a part of a group?
↧
↧

Clicking on hyperlink after google search based on href value

May 22, 2017, 4:09 pm
$
0
0
hello,

I have a macro that opens IE, navigates to google and conducts a search, but I'm stuck on how to click a certain link after the search is completed. Here is my code so far:
__________________________________________________________

'opening internet explorer'
Dim ie As Object
Set ie = CreateObject("internetexplorer.application")
With ie
.Visible = True
.navigate "www.google.com"
End With

'Wait while IE loads'
Do While ie.ReadyState = 4: DoEvents: Loop
Do Until ie.ReadyState = 4: DoEvents: Loop

'inputting search item'
Var = "J.C Beaudin hockeydb"
ie.document.getelementbyID("lst-ib").Value = Var

'clicking search button'
ie.document.forms(0).submit

Do While ie.ReadyState = 4: DoEvents: Loop
Do Until ie.ReadyState = 4: DoEvents: Loop

__________________________________________________________


looking at the element of the link I want to click, I get this:

__________________________________________________________

href="http://www.google.com/SearchTextHere'> Text of Hyperlink Displayed on Google
__________________________________________________________

Is there a way I can tell the macro to click on the hyperlink base on the href value or the text that follows it?
I know that the first link that shows up will always be the first link that appears, based on my initial search text.

Appreciate the help!!
Cheers

{{EDIT}}
I figured it out!
This is the code I used:

ie.document.getElementsByTagName ("a")
For Each l In ie.document.getElementsByTagName("a")
If l.outerText = "website outertext" Then
l.Click
Exit For
End If
Next
↧

Jump list problem

May 23, 2017, 12:00 am
$
0
0
Hi, Is there anyway not to show a specific file on a jump list..? The files will be opened on various PC's and I want to make sure that from the moment the installation has been done, the files do not appear in the jump list the moment the client open the file. It is mainly Microsoft Office Files like PowerPoint and excel

Thanking you in advance
↧

Convert folder name and file location to a clickable link in excel

May 23, 2017, 8:06 am
$
0
0
Hello:

I have a link like this, just as text:

C:\Vault\Sales\Projects\Adam\3D Printing customer call campaign.docx

I would like this to be a local link that can be clicked on to open the file. I need to populate excel with the link, not the text.

Thanks!
↧

Problems with #VALUE in VBA Function - SOLVED!

May 22, 2017, 4:54 am
$
0
0
HI all,

I have the following user definde function. The idea is cell contains any of a value list. (Like FIND, but with a list):

Code:
Public Function FINDS(cells_range As Range, find_in As Range) As Boolean
Application.Calculation = xlCalculationAutomatic
Application.Volatile True
Dim value As Boolean
Dim micell As Range

valor = False

For Each micell In cells_range
    If WorksheetFunction.IsError(WorksheetFunction.Search(micelda.value, find_in, 1)) = False Then
        valor = True
        GoTo etiqueta
    End If
Next micelda

etiqueta:
FINDS = value

End Function
The problem appears when Worksheet.Function.Seach returns a #VALUE, cause all VBA Function returns #VALUE.

Any help?
↧
↧

selenium vba runtime-error 438

May 23, 2017, 9:09 pm
$
0
0
I am learning selenium vba
The below code occurred runtime-error 438
I want to use "Hidecommandpromptwindow" property in selenium vba
How can i use it ?

Have a nice day !!

driver.HideCommandPromptWindow = True runtime error 438 object doesn't support this property or method

Sub abc()
Dim driver As New SeleniumWrapper.WebDriver
driver.HideCommandPromptWindow = True
driver.Start "chrome", "https://www.google.com"
driver.Quit
driver.Close
End Sub


https://i.stack.imgur.com/H1z4f.jpg

https://github.com/danwagnerco/selenium-vba/issues/68

Name: vvvv.jpg Views: 40 Size: 56.8 KB
Attached Images
 
↧

Need help writing some VB code

May 24, 2017, 7:22 am
$
0
0
Hi, this is my first post so I don't know how it works yet.

If someone could write/assist me on some code that would be great, I'm looking for the code to:

Search a word document looking for "_id#" (the # is any number) and if it duplicates anywhere in the document to chance them both to "_id#(partial)".

Any help would be great as I am stumped...

Thanks

Adam, (a.k.a YodaBadger)
↧
Search

[RESOLVED] selenium vba runtime-error 438

May 23, 2017, 9:09 pm
$
0
0
I am learning selenium vba
The below code occurred runtime-error 438
I want to use "Hidecommandpromptwindow" property in selenium vba
How can i use it ?

Have a nice day !!

driver.HideCommandPromptWindow = True runtime error 438 object doesn't support this property or method

Sub abc()
Dim driver As New SeleniumWrapper.WebDriver
driver.HideCommandPromptWindow = True
driver.Start "chrome", "https://www.google.com"
driver.Quit
driver.Close
End Sub


https://i.stack.imgur.com/H1z4f.jpg

https://github.com/danwagnerco/selenium-vba/issues/68

Name: vvvv.jpg Views: 53 Size: 56.8 KB
Attached Images
 
↧

MsOf365 Macro / VB Coding help needed please

May 24, 2017, 11:28 pm
$
0
0
Good day,

Would someone be able to assist me with the vb coding on the below problem i have.

I am using Windows 10 with office 365, VB for applications 7.1

I have a generated and excel file for testing of products, the file contains 2 sheets, one which contains the parameters (data) and the other is the input sheet. The input sheet is updated according to production and this has got a Production order and a trace number in separate cells. When combined this would be the reference to where this must be saved. I added a hidden cell (L8) on the input sheet which merges the text of both and this needs to be the save as file name, this does not contain any thing other than text.

I want a print and save button which when clicked automatically prints the sheet to the printer and save the file as a PDF on the server.

When i run a macro it prints fine to the printer and also to the 3rd party application (Adobe) however there it requires a manual input of the file name, i have tried numerous things i found on the web to try and resolve it but for some reason it just goes to that point the whole time.

My experience in programming is limited to an extend and I only use this as a form of self defense.

Below is the codes i have tried so far:

Code 1:

Code:
Sub PrintSave()
'
' PrintSave Macro
' PrintSave
'
' Keyboard Shortcut: Ctrl+Shift+P
'
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
    IgnorePrintAreas:=False
End Sub

Sub CleanSave()
    Dim filename As String
    filename = "C:\Users\JJ\Desktop\test reports" & Range("H7").Text & ".pdf"
   
End Sub

Function strClean(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
    .Pattern = "[\[\]|\/\\:\*\?""<>]"
    .Global = True
    strClean = .Replace(strIn, vbNullString)
End Sub
Code 2:

Code:
Sub savepdf1()
'
' savepdf1 Macro
' savepdf1
'
' Keyboard Shortcut: Ctrl+q
'
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
End Sub

Code 3:

Code:
Sub saveaspdf()
'
' saveaspdf Macro
' Save as pdf
'
' Keyboard Shortcut: Ctrl+Shift+A
'
    Range("F10").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "Button 1"
    With Selection.Characters(Start:=1, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    Range("F9").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "Save as pdf" & Chr(10) & "ton 1"
    With Selection.Characters(Start:=1, Length:=17).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    Range("G10").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    ActiveSheet.Shapes("Button 1").ScaleWidth 1.4835167925, msoFalse, _
        msoScaleFromTopLeft
    Range("G11").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    ActiveWorkbook.Save
    Range("G10").Select
End Sub
Kind Regards
Please assist.
↧
↧

Need your help to work this faster and doesnt freeze when running the code.

May 25, 2017, 3:54 am
$
0
0
Code:
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
'dim all variables
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 = "VOID-Wrong Patient"
    Range("AC1").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:T35000")
    Range("T2:T35000").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 = "=IF(RC[-14]=R1C,"".25"",""0"")"
    Range("AC2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
    Selection.NumberFormat = "0.00"


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


    Range("V2:AB2").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("Total Work")
        .Caption = "Total Work"
        .Function = xlCount

    End With
    ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
        "Episodes").PivotFields("Productivity"), "Sum of Productivity", xlSum
    With ActiveSheet.PivotTables("Episodes").PivotFields("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("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"
'
'    Sheets("source").Select
'    Application.CutCopyMode = False
'    Selection.ClearContents
'    Sheets("Episodes").Select
'    Cells.EntireColumn.AutoFit

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


End Sub
===

hope to receive a response to you guys (experts). Appreciate your help on this.
↧

Need help to consolidate 4 workbook and put it on the sheet per workbook

May 25, 2017, 4:06 am
$
0
0
Need help to consolidate 4 workbook and put it on the sheet per workbook

i have a working workbook and this workbook have a module for the macro to work.
the function of this workbook is to gather all the data from different workbook from a different location.

when running the macro.. first workbook data will be placed on the sheet1 and second workbook data to place on the sheet 2 same with workbook 3 and 4.

by the way on the first workbook the only data that i need is column A, B, C, D to be transferred to sheet 1
second workbook the only data i need is column A, B, K, L to be transferred to sheet 2
third workbook the only data i need is column A, B, C, F, M, N, O, P sheet 3

4th workbook the only data i need is A, B, C, E, F, G, H to sheet 4


Would appreciate if anyone from the geek squad could help me out to achieve this.
↧

MsOf365 [RESOLVED] Macro / VB Coding help needed please

May 24, 2017, 11:28 pm
$
0
0
Good day,

Would someone be able to assist me with the vb coding on the below problem i have.

I am using Windows 10 with office 365, VB for applications 7.1

I have a generated and excel file for testing of products, the file contains 2 sheets, one which contains the parameters (data) and the other is the input sheet. The input sheet is updated according to production and this has got a Production order and a trace number in separate cells. When combined this would be the reference to where this must be saved. I added a hidden cell (L8) on the input sheet which merges the text of both and this needs to be the save as file name, this does not contain any thing other than text.

I want a print and save button which when clicked automatically prints the sheet to the printer and save the file as a PDF on the server.

When i run a macro it prints fine to the printer and also to the 3rd party application (Adobe) however there it requires a manual input of the file name, i have tried numerous things i found on the web to try and resolve it but for some reason it just goes to that point the whole time.

My experience in programming is limited to an extend and I only use this as a form of self defense.

Below is the codes i have tried so far:

Code 1:

Code:
Sub PrintSave()
'
' PrintSave Macro
' PrintSave
'
' Keyboard Shortcut: Ctrl+Shift+P
'
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
    IgnorePrintAreas:=False
End Sub

Sub CleanSave()
    Dim filename As String
    filename = "C:\Users\JJ\Desktop\test reports" & Range("H7").Text & ".pdf"
   
End Sub

Function strClean(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
    .Pattern = "[\[\]|\/\\:\*\?""<>]"
    .Global = True
    strClean = .Replace(strIn, vbNullString)
End Sub
Code 2:

Code:
Sub savepdf1()
'
' savepdf1 Macro
' savepdf1
'
' Keyboard Shortcut: Ctrl+q
'
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
End Sub

Code 3:

Code:
Sub saveaspdf()
'
' saveaspdf Macro
' Save as pdf
'
' Keyboard Shortcut: Ctrl+Shift+A
'
    Range("F10").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "Button 1"
    With Selection.Characters(Start:=1, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    Range("F9").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "Save as pdf" & Chr(10) & "ton 1"
    With Selection.Characters(Start:=1, Length:=17).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    Range("G10").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    ActiveSheet.Shapes("Button 1").ScaleWidth 1.4835167925, msoFalse, _
        msoScaleFromTopLeft
    Range("G11").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    ActiveWorkbook.Save
    Range("G10").Select
End Sub
Kind Regards
Please assist.
↧
Viewing all 4673 articles
Browse latest View live
Search