lundi 20 avril 2015

VBA written in Excel for Windows not working on Mac

I have a set of macros to hide and unhide columns based on the contents of a specific row. They were all written in Excel 2013 for Windows (running in parallels on my MBA, if that's relevant) and work fine there. But when I open the worksheet in Excel 2011 for Mac, the macros give odd results. The "unhide all columns" macro works fine; the other functions get as far as hiding all columns but not as far as unhiding the ones I want to see.

I can only assume Excel for Mac is having a problem with what's in the FOR EACH loop, but I can't figure out what! I'd appreciate any guidance: I need to get this system working on both Windows and Mac.

Code below.

This function works:

Sub GANTT_Filter_Show_All()

Dim rngDates As Range

Set rngDates = Range("GANTT_Dates")

rngDates.EntireColumn.Hidden = False

End Sub

But this one only hides all the columns:

Sub GANTT_Filter_This_Quarter()

Dim intCurrentMonth As Integer, intCurrentYear As Integer, rngDates As Range, cell As Range
Dim intCurrentQuarterMonths(3) As Integer

Set rngDates = Range("GANTT_Dates")
intCurrentMonth = DatePart("m", Date)
intCurrentYear = DatePart("yyyy", Date)

'loading months of current quarter into an array intCurrentMonth

Select Case intCurrentMonth
    Case 1 To 3
        intCurrentQuarterMonths(0) = 1
        intCurrentQuarterMonths(1) = 2
        intCurrentQuarterMonths(2) = 3
    Case 4 To 6
        intCurrentQuarterMonths(0) = 4
        intCurrentQuarterMonths(1) = 5
        intCurrentQuarterMonths(2) = 6
    Case 7 To 9
        intCurrentQuarterMonths(0) = 7
        intCurrentQuarterMonths(1) = 8
        intCurrentQuarterMonths(2) = 9
    Case 10 To 12
        intCurrentQuarterMonths(0) = 10
        intCurrentQuarterMonths(1) = 11
        intCurrentQuarterMonths(2) = 12
    End Select

'hiding all columns

rngDates.EntireColumn.Hidden = True

'comparing each column to array of months in current quarter and hiding if false

For Each cell In rngDates
    For Each v In intCurrentQuarterMonths
        If v = DatePart("m", cell.Value) And DatePart("yyyy", cell.Value) = intCurrentYear Then cell.EntireColumn.Hidden = False
    Next v
Next cell

Application.Goto Reference:=Range("a1"), Scroll:=True

End Sub

How to press the second button with VBA Excel Internet Explorer

I am trying to press a button with ID "run-report" the issue is that there is two buttons with the same ID and I want to press the second button.

Set tags = ie.Document.GetElementsByTagname("input") 
For Each tagx 
In tags If tagx.Value = "Run report" 
Then tagx.Click 
End If 
Next

This works for the first button but can not find a way to press the second one. Anyone got any tips?

Thanks in advance

Print Date and time in fixed column instead offset for Log of events

Gentlemen, I´d like to create a log of events. With a form I´ll fill cells on the same row starting in column C and I´d like date and time printed automatically in columns A and B. Sometimes information might start from column D and C would be empty. The code below does that through an offset from column C and C only. Even if I expand the range for Intersect, the date and time will be carried out and not stay fixed in A and B. Does anyone would have a hint for me?

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim rCell As Range
    Dim rChange As Range

    On Error GoTo ErrHandler
    Set rChange = Intersect(Target, Range("C:C"))
    If Not rChange Is Nothing Then
        Application.EnableEvents = False
        For Each rCell In rChange
            If rCell > "" Then
                With rCell.Offset(0, -2)
                    .Value = Date
                    .NumberFormat = "[$-2C09]ddd, DD/MM/YYYY"
                    .HorizontalAlignment = xlLeft
                    .EntireColumn.AutoFit
                End With
                With rCell.Offset(0, -1)
                    .Value = Time
                    .NumberFormat = "hh:mm"
                    .HorizontalAlignment = xlCenter
                    .EntireColumn.AutoFit
                End With
            Else
                rCell.Offset(0, -1).Clear
                rCell.Offset(0, -2).Clear
            End If
        Next
    End If

ExitHandler:
    Set rCell = Nothing
    Set rChange = Nothing
    Application.EnableEvents = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

VBA Code to shift sourcedata in an excel chart

I am trying to update my sourcedata in a chart. I Don't want a dynamic range because the chart will pull each time from the new range with each button click. If I use a dynamic or named range, I am locked into that range.

I have tried:

ActiveSheet.ChartObjects("Chart 2").Activate

ActiveChart.PlotArea.Select

ActiveChart.SetSourceData Source:=Range("A1:C3").Offset(0,3)

This only works once, though. To be clear, I have a button to update a chart on a spreadsheet. When the button is clicked, the macro will look at the current data in the active chart and shift the source over 3 columns. This will happen each time the button is clicked and the data must stay on the sheet. I've exhausted everything I know and can find online the Goracle search.

Any help?

Thanks in advance, Lilith

vba create a new sheet and change name

I am a VBA new user. My purpose is copy a existing worksheet to a new one. And then change the new worksheet name to a proper name. However, I got the VBA Error Message like,

vba runtime error 9 subscript out of range(at the line Set new_ws =Active...)

The VBA code will be the following; thanks in advance

Sub CreateWS()
Dim ws As Worksheet
Dim new_ws As Worksheet

    Set ws = ActiveWorkbook.Worksheets("Bus Voltage")
    ws.Name = "Bus Voltage_All"
    ws.Copy Worksheets(Sheets.Count)
    Set new_ws = ActiveWorkbook.Worksheets("Bus Voltage_All(2)")
    new_ws.Name = "Bus Voltage"
End Sub

How to record mouse clicks in Excel VBA?

I am trying to make a macro that records what a user clicked, which then records the mouse coordinates and the delay between the clicks. This will then repeat after some other SendKey changes. How can I detect when I click the mouse when the macro is running? I already know how to get the coordinates and record the delay, but what is the best course of action for detecting the mouse click and also what would be the best way to save all this information? A text file? Here is a snippet of the mouse click events that I use:

Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
x As Long
y As Long
End Type
Public pos As POINTAPI ' Declare variable

Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10

Public Sub SingleClick()
Dim xval, yval
xval = GetSetting("Will's Program Sheet", "DPS Calibration", "PROGRAM X")
yval = GetSetting("Will's Program Sheet", "DPS Calibration", "PROGRAM Y")
Select Case xval
Case Is = "" 'Runs calibrate if it can't find an xval
    Call CALIBRATE
    End
End Select
  SetCursorPos xval, yval  'x and y position
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

There is another macro that calls SingleClick where it moves to a constant x and y, clicks, does some magic, and returns to the position before the macro started. So to reiterate, is there a simple or easy to understand method to record multiple clicks and delays between clicks and replay them through Excel VBA?

Compare two sets of name lists and create a report showing matching names in VBA

I have two sets of lists: 1) customer list in sheet1: name, last name, DOB 2) black list 1 in sheet2: name last name, DOB 2) black list 2 in sheet3: name last name, DOB 2) black list 3 in sheet4: name last name, DOB

I need a VBA code to check the customer list and identify the ones that appear in one or more of the blacklists. Return the results in a seperate sheet showing the following info:

  1. Customer name, last name, DOB
  2. Which blacklists does the customer appears to be in?
  3. Matching results from the blacklists

I would greatly appreciate any input that can help me generate a VBA code for this task. Thanks!

every possible combination of the contents of 2 columns in excel

Suppose I have 2 Columns:

1st column(contains 1000 rows):

U-0001

U-0002 

2nd column(contains 10 rows):

B01

B02

B03

Now, I want to generate two columns like this(with 10*1000 = 10000 rows):

U-0001 B01

U-0001 B02

U-0001 B03

U-0002 B01

U-0002 B02

U-0002 B03

excel VBA, trying to print an area?

I'm making a big workbook at the moment, trying to get it so at the end of each month I run a macro which generates the new sheet.

I've got this sorted now.

Next is having a macro which gives the user an option to Print only the relevant information from the sheet.

This gets kind of complicated! As certain columns in the midst of the data shouldn't be printed, however I still want them to be visible at all other times.

My solution:

(note I am pretty new to VBA, and this was quite complicated for me so I just used macro recorder)

I split it up into two steps, one is a macro is called by pressing 'Create Print Area' button on sheet and the next is a macro called by a 'Send To Printer' button

Create Print Area Macro - Hides all undesired columns then highlights all cells from "$B$1:$Y$567", then makes this the print area.

Send to Printer Macro - Sends the print area to printer. It has the settings of A3 size, fiting columns to width, having $1:$1 as the print title and otherwise just default settings I think. I then unhide the cells hidden from running the Print Area Macro.

The problem: So far the first macro appears to be working, and by in large the second macro seems to be working. However despite printing in the right size, right number of columns and correct print titles, it's printing all the rows in the sheet. (ie not cutting off at Row 567). This isn't a huge problem as I only have 10 rows of data after 567, but it's a bit annoying as it means an extra unnecessary page is produced as well as it looking a bit messy, Ideally I could get rid of these additional rows printed.

Any suggestions? I've spent ages trying to figure it out without success.

Attached is my code for the second macro (note long and messy as done with macro recorder).

Sub printSheetSend()
'
' printSheetSend Macro
'

'
Application.Goto Reference:="Print_Area"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$1"
    .PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$B$1:$Y$567"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0.7)
    .RightMargin = Application.InchesToPoints(0.7)
    .TopMargin = Application.InchesToPoints(0.75)
    .BottomMargin = Application.InchesToPoints(0.75)
    .HeaderMargin = Application.InchesToPoints(0.3)
    .FooterMargin = Application.InchesToPoints(0.3)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = False
    .CenterVertically = False
    .Orientation = xlLandscape
    .Draft = False
    .PaperSize = xlPaperA3
    .FirstPageNumber = xlAutomatic
    .Order = xlDownThenOver
    .BlackAndWhite = False
    .zoom = 100
    .PrintErrors = xlPrintErrorsDisplayed
    .OddAndEvenPagesHeaderFooter = False
    .DifferentFirstPageHeaderFooter = False
    .ScaleWithDocHeaderFooter = True
    .AlignMarginsHeaderFooter = True
    .EvenPage.LeftHeader.Text = ""
    .EvenPage.CenterHeader.Text = ""
    .EvenPage.RightHeader.Text = ""
    .EvenPage.LeftFooter.Text = ""
    .EvenPage.CenterFooter.Text = ""
    .EvenPage.RightFooter.Text = ""
    .FirstPage.LeftHeader.Text = ""
    .FirstPage.CenterHeader.Text = ""
    .FirstPage.RightHeader.Text = ""
    .FirstPage.LeftFooter.Text = ""
    .FirstPage.CenterFooter.Text = ""
    .FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Application.PrintCommunication = False
With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$1"
    .PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$B$1:$Y$567"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0.7)
    .RightMargin = Application.InchesToPoints(0.7)
    .TopMargin = Application.InchesToPoints(0.75)
    .BottomMargin = Application.InchesToPoints(0.75)
    .HeaderMargin = Application.InchesToPoints(0.3)
    .FooterMargin = Application.InchesToPoints(0.3)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = False
    .CenterVertically = False
    .Orientation = xlLandscape
    .Draft = False
    .PaperSize = xlPaperA3
    .FirstPageNumber = xlAutomatic
    .Order = xlDownThenOver
    .BlackAndWhite = False
    .zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    .PrintErrors = xlPrintErrorsDisplayed
    .OddAndEvenPagesHeaderFooter = False
    .DifferentFirstPageHeaderFooter = False
    .ScaleWithDocHeaderFooter = True
    .AlignMarginsHeaderFooter = True
    .EvenPage.LeftHeader.Text = ""
    .EvenPage.CenterHeader.Text = ""
    .EvenPage.RightHeader.Text = ""
    .EvenPage.LeftFooter.Text = ""
    .EvenPage.CenterFooter.Text = ""
    .EvenPage.RightFooter.Text = ""
    .FirstPage.LeftHeader.Text = ""
    .FirstPage.CenterHeader.Text = ""
    .FirstPage.RightHeader.Text = ""
    .FirstPage.LeftFooter.Text = ""
    .FirstPage.CenterFooter.Text = ""
    .FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Application.PrintCommunication = False
With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$1"
    .PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$B$1:$Y$567"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0.7)
    .RightMargin = Application.InchesToPoints(0.7)
    .TopMargin = Application.InchesToPoints(0.75)
    .BottomMargin = Application.InchesToPoints(0.75)
    .HeaderMargin = Application.InchesToPoints(0.3)
    .FooterMargin = Application.InchesToPoints(0.3)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = False
    .CenterVertically = False
    .Orientation = xlLandscape
    .Draft = False
    .PaperSize = xlPaperA3
    .FirstPageNumber = xlAutomatic
    .Order = xlDownThenOver
    .BlackAndWhite = False
    .zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 0
    .PrintErrors = xlPrintErrorsDisplayed
    .OddAndEvenPagesHeaderFooter = False
    .DifferentFirstPageHeaderFooter = False
    .ScaleWithDocHeaderFooter = True
    .AlignMarginsHeaderFooter = True
    .EvenPage.LeftHeader.Text = ""
    .EvenPage.CenterHeader.Text = ""
    .EvenPage.RightHeader.Text = ""
    .EvenPage.LeftFooter.Text = ""
    .EvenPage.CenterFooter.Text = ""
    .EvenPage.RightFooter.Text = ""
    .FirstPage.LeftHeader.Text = ""
    .FirstPage.CenterHeader.Text = ""
    .FirstPage.RightHeader.Text = ""
    .FirstPage.LeftFooter.Text = ""
    .FirstPage.CenterFooter.Text = ""
    .FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True

' ADD: send shit to printer here
Columns("G:G").Select
Selection.EntireColumn.Hidden = False
Columns("I:I").Select
Selection.EntireColumn.Hidden = False
Columns("L:L").Select
Selection.EntireColumn.Hidden = False
Columns("O:O").Select
Selection.EntireColumn.Hidden = False
Columns("T:T").Select
Selection.EntireColumn.Hidden = False
Columns("U:U").Select
Selection.EntireColumn.Hidden = False
Columns("V:V").Select
Selection.EntireColumn.Hidden = False
Range("B1").Select
End Sub

Automation of IE via VBA executes as intended, but throws an automation error

I have the following code, which is supposed to open Internet Explorer in order to download a file.

Sub hentRapport()
  Dim IEapp As Object
  Dim WebUrl As String

  Set IEapp = CreateObject("InternetExplorer.Application") 'Set IEapp = InternetExplorer
  WebUrl = Oversikt.Range("Adresse")

  With IEapp
    .Silent = True 'No Pop-ups
    .Visible = True 'Set InternetExplorer to Visible
    .Navigate WebUrl 'Load web page

    'Run and Wait, if you intend on passing variables at a later stage
    Do While .Busy
        DoEvents
    Loop

    Do While .ReadyState <> 4
        DoEvents
    Loop
  End With
End Sub

Internet Explorer (IE 11.0.9600.17691) opens as expected, and I get up the dialog for downloading the file, but at the same time I get an error from the macro:

enter image description here

The error happens on the line

Do While .ReadyState <> 4

and I can't figure out why. Doesn't that line simply state that Excel doesn't need to wait for IE to do its thing before accepting other input?

Adding multiple PivotFields in Excel VBA

I'm trying to make a macro which makes a PivotTable. Currently I've been able to find some code that helped me create it, the problem is that I can't find a way to add various PivotFields using a for look or array, currently I use this code to add PivotFields:

'set data field - specifically change orientation to a data field and
'set its function property:
 With PvtTbl.PivotFields("S1")

.Orientation = xlDataField

.Function = xlSum

.NumberFormat = "#,##0"

.Position = 1

End With

With PvtTbl.PivotFields("S2")

.Orientation = xlDataField

.Function = xlSum

.NumberFormat = "#,##0"

.Position = 2

End With

As you can see i just repeat the same code to add another field, is there a better way for adding multiple fields instead of just copy paste the same code? I need to add 22 fields.

How to change text format using wildcards in VBA

Our Word documents have several occurrences of the text "Division XX" where XX ranges from 00 thru 99. I need to boldface these using VBA. Below is some code I adopted which gets me part way

With mDoc.Tables(1).Cell(1, 1).Range.Find
       .Forward = True
       .Wrap = wdFindStop
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
       .Replacement.Font.Bold = True

       .Execute FindText:="Division", Format:=True, ReplaceWith:="Division", Replace:=wdReplaceAll
    End With

However, it doesn't select or highlight the " XX". I tried and failed to use wildcards because it wasn't clear to me what to use for the ReplaceWith value?

how to export message body and data from Table to Excel from outlook 2010

I usually get Employee announcement in emails and I need to compile excel sheet from all these emails to know change in status of employee from previous line to current line .

Dear Concerned,

The change in status of the following employee has been carried out as per following details:

New Status

Change in Job

Effective Date

01-Feb-2015

Employee Name

Ricky ponting

Employee Code

4982

Designation

Sourcing Executive (Secondment)

Job Group

1A

Department

Sourcing & Supply Chain

Unit

Technology Sourcing

Division

Finance

Location

Islamabad

Reporting Line

Mr Micheal king

Note: Ricky Ponting was previously working as Tariff Implementation Support Officer in the org Communication dept and was reporting to Mr Robin Sing.

I need working code that export about HTML table data as well last Note : full line so that I can have an excel file of 2000 Employees whoes status have been changed and I can easily sort out from which previous line they were reporting to new line and I can get in touch with the new line for any Access rights re-authorization exercise on later stage .

Currently i am using following code thats working fine with the table extraction but NOTE: line is not being fetched with the following code based on following URL

http://ift.tt/1yLZ6vS

    Const MACRO_NAME = "Export Messages to Excel (Rev Sajjad)"

Private Sub ExportMessagesToExcel()
    Dim olkFld As Outlook.MAPIFolder, _
        olkMsg As Outlook.MailItem, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        arrCel As Variant, _
        varCel As Variant, _
        lngRow As Long, _
        intPtr As Integer, _
        intVer As Integer
    Set olkFld = Session.PickFolder
    If TypeName(olkFld) = "Nothing" Then
        MsgBox "You did not select a folder.  Operation cancelled.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        excApp.Visible = True
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "New Status"
            .Cells(1, 5) = "Effective Date"
            .Cells(1, 6) = "Employee Name"
            .Cells(1, 7) = "Employee Code"
            .Cells(1, 8) = "Designation"
            .Cells(1, 9) = "Job Group"
            .Cells(1, 10) = "Department"
            .Cells(1, 11) = "Unit"
            .Cells(1, 12) = "Division"
            .Cells(1, 13) = "Location"
            .Cells(1, 14) = "Reporting Line"
            .Cells(1, 15) = "Note:"
          End With
        lngRow = 2
        For Each olkMsg In olkFld.Items
            excWks.Cells(lngRow, 1) = olkMsg.Subject
            excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
            arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
            For intPtr = LBound(arrCel) To UBound(arrCel)
                Select Case Trim(arrCel(intPtr))
                    Case "New Status"
                        excWks.Cells(lngRow, 4) = arrCel(intPtr + 1)
                    Case "Effective Date"
                        excWks.Cells(lngRow, 5) = arrCel(intPtr + 1)
                    Case "Employee Name"
                        excWks.Cells(lngRow, 6) = arrCel(intPtr + 1)
                    Case "Employee Code"
                        excWks.Cells(lngRow, 7) = arrCel(intPtr + 1)
                    Case "Designation"
                        excWks.Cells(lngRow, 8) = arrCel(intPtr + 1)
                    Case "Job Group"
                        excWks.Cells(lngRow, 9) = arrCel(intPtr + 1)
                    Case "Department"
                        excWks.Cells(lngRow, 10) = arrCel(intPtr + 1)
                    Case "Unit"
                        excWks.Cells(lngRow, 11) = arrCel(intPtr + 1)
                    Case "Division"
                        excWks.Cells(lngRow, 12) = arrCel(intPtr + 1)
                    Case "Location"
                        excWks.Cells(lngRow, 13) = arrCel(intPtr + 1)
                    Case "Reporting Line"
                        excWks.Cells(lngRow, 14) = arrCel(intPtr + 1)
                    Case "Note:"
                        excWks.Cells(lngRow, 15) = arrCel(intPtr + 1)
                    End Select
            Next
            lngRow = lngRow + 1
        Next
        excWks.Columns("A:W").AutoFit
        excApp.Visible = True
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
    End If
    Set olkFld = Nothing
End Sub

Private Function GetCells(strHTML As String) As String
    Const READYSTATE_COMPLETE = 4
    Dim IE As Object, objDoc As Object, colCells As Object, objCell As Object
    Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.navigate "about:blank"
    Do While IE.ReadyState <> 4: DoEvents: Loop
        DoEvents
    Set Doc = CreateObject("htmlfile")
    IE.document.Body.innerHTML = strHTML
    Set objDoc = IE.document
    Set colCells = objDoc.getElementsByTagName("td")
    If colCells.Length > 0 Then
        For Each objCell In colCells
            GetCells = GetCells & objCell.innerText & Chr(255)
        Next
        GetCells = Left(GetCells, Len(GetCells) - 1)
    Else
        GetCells = ""
    End If
    Set objCell = Nothing
    Set colCells = Nothing
    Set objDoc = Nothing
    IE.Quit
    Set IE = Nothing
End Function

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://ift.tt/1mlp9DO")
    On Error GoTo 0
    Set olkPA = Nothing
End Function


Sub DebugLabels()
    Dim olkMsg As Outlook.MailItem, objFSO As Object, objFil As Object, strBuf As String, strPth As String, arrCel As Variant, intPtr As Integer
    strPth = Environ("USERPROFILE") & "\Documents\Debugging.txt"
    Set olkMsg = Application.ActiveExplorer.Selection(1)
    arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
    For intPtr = LBound(arrCel) To UBound(arrCel)
        strBuf = strBuf & StrZero(intPtr, 2) & vbTab & "*" & arrCel(intPtr) & "*" & vbCrLf
    Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFil = objFSO.CreateTextFile(strPth)
    objFil.Write strBuf
    objFil.Close
    Set olkMsg = Application.CreateItem(olMailItem)
    With olkMsg
        .Recipients.Add "TechnicLee@earthlink.net"
        .Subject = "Debugging Info"
        .BodyFormat = olFormatPlain
        .Body = "The debugging info for the selected message is attached.  Please click Send to send this message to David."
        .Attachments.Add strPth
        .Display
    End With
    Set olkMsg = Nothing
    Set objFSO = Nothing
    Set objFil = Nothing
End Sub

Function StrZero(varNumber, intLength)
    Dim intItemLength
    If IsNumeric(varNumber) Then
        intItemLength = Len(CStr(Int(varNumber)))
        If intItemLength < intLength Then
            StrZero = String(intLength - intItemLength, "0") & varNumber
        Else
            StrZero = varNumber
        End If
    Else
        StrZero = varNumber
    End If
End Function

Find and Replace in VBA

I am attempting to go through a column of department names (strings) and anything that contains the string " - INACTIVE" needs to have it deleted and just have the department name. For instance, if I had "Jacksonville - INACTIVE", I would want it to simply be "Jacksonville" in the column cell. I have attempted to use the .Find and .Replace methods but I don't seem to grasp the way the way to use them.

I have attempted it with help from a friend and this is what i have so far. I am new to this language.

 Sub DeleteRows()

    Dim c As Range
    Dim SrchRng
    Dim InactiveDepartment As String
    Dim Department As String

 Range("A1").Select

 InactiveDepartment = ActiveCell.Value

 Set SrchRng = ActiveSheet.UsedRange

 Do Until ActiveCell.Value = ""
     Set c = SrchRng.Find("INACTIVE", LookIn:=xlValues)
     If Not c Is Nothing Then
         Department = Replace(InactiveDepartment, " - INACTIVE", "")
         ActiveCell.Value = Department
         ActiveCell.Offset(1, 0).Select
    Else
         ActiveCell.Offset(1, 0).Select
    End If
Loop

End Sub

exel macros getting an image from url

i´m making a macro on exel 2013 to get the URL from a column(Column "f" and put it on the next column(Column "G") i already make a code but it dosent work as i want

Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range) With rngTarget.Parent .Pictures.Insert strShpUrl .Shapes(.Shapes.Count).Left = rngTarget.Left .Shapes(.Shapes.Count).Top = rngTarget.Top End With End Sub

Sub Obtener_imagen() On Error Resume Next For i = 2 To 3 Call GetShapeFromWeb(Range("f" & i).Value, Hoja1.Range("a65536").End(xlUp).Offset(6, i)) Next i End Sub

Copy values from multiple rows

All I need to do is copy values from different rows, say row A40:D40, A47:D47 etc. I have the code that runs properly for one row at a time, but when I try to do two different rows say A40:D40 and A47:D47 it will copy A40:D40 & A41:D41.

Sub LoopCopyValues()
Dim MyFile As String
Dim FilePath As String


FilePath = "C:\Users\"
MyFile = Dir(FilePath)

Do While Len(MyFile) > 0
    If MyFile = "Master Macro.xlsm" Then
    Exit Sub
End If

Workbooks.Open (FilePath & MyFile)

ActiveWorkbook.Worksheets("A2) Monthly P&L (Source)").Activate

Range("CZ447:DC447").Copy

ActiveWorkbook.Close False

Range("B" & Rows.Count).End(xlUp).Offset(1).Select

ActiveSheet.Paste

MyFile = Dir

Loop

End Sub

ArcMap label min and max values

hello all.

I'd like to ask you to kindly help me to find a solution of a following question on which I was not able to find an answer so far. The issue stands as follows: I've got a point layer of 1000s of points which contains (among other attributes) a field "File" and a field "Distance". The "file" field defines by unique text strings a series of interrelated points (one file is one measurement of a device) while the "distance" field obviously indicates a distance from 0 (or a number close to zero) to MaxDistance (usually hundreds or thousands of metres). I'd like to label only the first and last point of each file series (i.e. the point with the lowest and highest value within each file defined category) Could you help me with defining the right VBA (or python) script to do this?

I'm trying to start to learn the scripting basics (I'd also appreciate if you could suggest which scripting language is more useful to learn / use for ESRI products, though feeling this might be a tricky question :-)) but in this case I need some help as I'm quite under pressure with finishing the task.

Thanks in advance for your kind help and best regards, Filip.

Why do I get different results when using len vs vba.len in vba for excel?

When I run the following macro:

Sub try()

Dim num As Integer

num = 123

MsgBox Len(num)

MsgBox VBA.Len(num)

End Sub

The first msgbox displays 2 and the second msgbox displays 3. If I remove the first line, Dim i as integer, both msgboxs display 3. Can anyone explain why? Thank you.

vbmsgBox prompt is a mix of RTL(Persian) and LTR(English) but text is displayed in wrong order

I am designing a vba userform for excel 2013, in which I use English and Persian text, the problem is when I use a mix of both languages in a msgBox the bits of text come out in the wrong order, the number is supposed to be displayed at the end. here is the code:

Private Sub CommandButton1_Click()
   MsgBox "نام" & " - " & "نام" & " - " & "VF" & " - " & 52 & " ." _
   , 1 + 1048576 + 524288, "نام برگه"
End Sub

The parts in double quotes and the number are supposed to come from listBoxes.(I just replaced them here with examples, the code behaves the same) I tried spacing the bits out(works in windows), rearranging the bits and changing msgBox's alignment and reading order, but the result was the same. How to fix this thing?

Multdimensional array in VBA for Microsoft Word on Mac

I'm working on a macro to loop through a series of strings (a1, a2, a3) and replace them with a series of corresponding values (b1, b2, b3). I've created an array to store the strings to match:

Dim search_strings(1 To 2) As String
search_strings(1) = "match1"
search_strings(2) = "match2"

I can loop through this array with a For Each loop. But I can't figure out how to store and reference the corresponding replacement text. I know that I need some sort of key/value pair. I've tried using a dictionary, like this:

Dim dict As New Scripting.Dictionary
dict.Add "match", "replace"

But for that to work, I need to reference Microsoft Scripting Runtime, which isn't available on Mac OS X. (Currently, I get this error: Compile error: User-defined type not defined.)

Is there another way?

Here's the full code:

Sub MyMacro()
    ' Initialize variables
    Dim search_strings(1 To 2) As String
    Dim this_search_string As Variant
    Dim myRange As Range
    Dim Reply As Integer
    ' Define strings to match
    search_strings(1) = "match1"
    search_strings(2) = "match2"
    ' Run a search for each string in the array of strings to match
    For Each this_search_string In search_strings
        ' Define the search range to be the whole document
        Set myRange = ActiveDocument.Content
        ' Set the Find parameters
        myRange.Find.ClearFormatting
        myRange.Find.MatchWildcards = True
        ' Loop through each match in the document
        Dim cached As Long
        cached = myRange.End
        Do While myRange.Find.Execute(this_search_string)
            myRange.Select
            ' Prompt the user to replace the match
            Reply = MsgBox("Replace '" & myRange.Find.Text & "'?", vbYesNoCancel)
            If Reply = 6 Then ' "Yes" clicked
                myRange.Text = "replacement"
            ElseIf Reply = 2 Then ' "Cancel" clicked
                Exit Do
            End If
            myRange.Start = myRange.Start + Len(myRange.Find.Text)
            myRange.End = cached
        Loop
    Next this_search_string
End Sub

VBA MS ACCESS - Login form redirect to different form based on selected button

I have login form:

http://ift.tt/1yLEi7J

Each button decides what source will be used by cbUserLogin ("Nazwa" on screenshot)

CODE:

Private Sub buttonUAP1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Forms!MainLoginForm!cbUserLogin.RowSourceType = "Table/Query"
    Forms!MainLoginForm!cbUserLogin.RowSource = "queryUsersUAP1"
End Sub

And for each button the same code with the different query source.

I want to do something to actually decide where user will be directed based on that button.

If while logging in UAP 1 button is selected and login and password will match i want to land user in form_UAP1, if button UAP 2 will be selected while logging in i want to make user land on form_UAP2, etc.

Im trying to bite that thing for already some days and i just can't find solution.

Excel VBA: Formula Not Entering Correctly From String

I'm trying to finish a script that will allow a user to select another excel file when a cell is double clicked, then that excel file is used to drop in a formula into the main excel file. I cannot use the cell values alone because being able to see the file path in the formula bar when the script is complete is required. So the issue is that the formula being entered does not match the string text that it should be pulling from.

For clarification, the string I use called FormulaPath ends up being a formula ending "...\00975-006-00[00975-006-00.xls]QuoteDetails'!" and this would be the correct formula. But when I use this to enter the formula into a range:

Range("A1").Formula = "=" & FormulaPath & "$C$100"

The actual formula ends up being entered as "...[00975-006-00[00975-006-00.xls]Quote Details]00975-006-00[00975-006-00.xls]Q'!$C$100

Notice the repetition?

I'm on mobile right now, so forgive me if the formatting is wacky. Full script below. Thanks!

Option Explicit



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)



Dim ImportWB, QuoteWB As Workbook

Dim AdInsWS, AdInsCostWS As Worksheet

Dim ImportPathName As Variant

Dim FormulaPath As String



Set QuoteWB = ThisWorkbook

Set AdInsWS = QuoteWB.Sheets("Ad-Ins")

Set AdInsCostWS = QuoteWB.Sheets("Ad-ins cost")





    If Not Intersect(Target, Range("B:B")) Is Nothing Then



    'set default directory

    ChDrive "Y:"

    ChDir "Y:\Engineering Management\Manufacturing Sheet Metal\Quotes"



        'open workbook selection

        ImportPathName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Please select a file")



        If ImportPathName = False Then 'if no workbook selected

            MsgBox "No file selected."

        ElseIf ImportPathName = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then 'if quote builder workbook selected

            MsgBox "Current quote workbook selected, cannot open."

        Else

            Application.DisplayAlerts = False

            Application.ScreenUpdating = False

                Workbooks.Open Filename:=ImportPathName, UpdateLinks:=False



                    Set ImportWB = ActiveWorkbook

                    FormulaPath = "'" & ImportWB.Path & "[" & ImportWB.Name & "]Quote Details'!"

                    AdInsCostWS.Range("B3").Formula = "=" & FormulaPath & "$C$100"

                    ImportWB.Close



        End If



        Cancel = True

        Application.DisplayAlerts = True

        Application.ScreenUpdating = True



    End If



End Sub

How to extract cells of a particular colour in pivot table?

I have applied conditional formatting to one column of pivot table in excel which automatically colours the cells greater then a particular value by red colour each time. However, I also want to extract those red cells every time separately to a specific area in the same sheet.

Can someone please help here? Can it be done using macros or a 'if' condition would also help here?

Need to find a match between a column of IDs in worksheet (Sheet2) where these exist in a string in a column of another worksheet (Sheet1)

Gentlemen, I've redone the entire post.

The similar link mentioned before is:

Link to similar request for info

The more accurate question is how do I use Column 1 of Sheet2, here:

Project ID to Funding Types

... to find a match of a project ID here:

Sheet 1 , replace project ID in column D with funding types

... so that I get this end result:

Desired Result

The problem with Edit | Fill Down is obvious ... D5 is the cell to modify for the first of 26 projects, D9 is the next. I'll need to find a column/row reference by Project ID match more than likely.

I've looked at VLOOKUP(), SUBSTITUTE(), REPLACE(), SEARCH() which all seem to be pieces of the solution. An option open to me is to use VSTO since C#.Net I'm much more familiar with. Very easy to search a string in C# for a match from the 2nd worksheet | Column 1, etc. Those desiring the solution prefer VBA or a Macro or formula.

Hope I'm more to the point this time.

XML reading is not working in my ASP CLASSIC code - Load file returns FALSE

In my outlook 2013 I created a function that saves the sender, subject and domain name in variables. These variables are then transferred/created into an XML file which all works.

Though the next thing I want to achieve is to read the XML files variables and use them on my web page. The reading however does not work, it returns nothing.

The Outlook 2013 macro creates the XML file on a server, and it also ends up there (checked it). The ASP file is located on the same server of the XML file in the same folder.

My code is as follows:

The XML file that is created (with a xml extension)

<Mail2Memo>
    <Receiver>Nicolas</Receiver>
    <Domain>hotmail.com</Domain>
    <Subject>I am awesome</Subject>
</Mail2Memo>

The ASP code that should read, and output the XML values. (did the output in a table for now)

<!DOCTYPE html>
<HTML>
    <HEAD>
    <meta charset="utf-8">
    <TITLE>Send mails</TITLE>
    </HEAD>

    <BODY>  

    <%

        Set xmlDOM = Server.CreateObject("MSXML2.DOMDocument")
        xmlDOM.async = False
        xmlDOM.setProperty "ServerHTTPRequest", True
        xmlDOM.Load("MyXMLFile.xml")

        Test =  xmlDOM.Load("MyXMLFile.xml")
        response.write (Test)

        Set itemList = XMLDom.SelectNodes("Mail2Memo")

        For Each itemAttrib In itemList
           newReceiver =itemAttrib.SelectSingleNode("Receiver").text
           newDomain =itemAttrib.SelectSingleNode("Domain").text
           newSubject =itemAttrib.SelectSingleNode("Subject").text
           %>
           <tr>
              <td><%=newReceiver%></td>
              <td><%=newDomain%></td>
              <td><%=newSubject%></td>
           </tr>
        <%
        Next

        Set xmlDOM = Nothing
        Set itemList = Nothing

    %>

    </BODY>
</HTML> 

This code just returns an empty web page for some reason.. The test variable that I have build in (to see what goes wrong) returns the value FALSE, so I am guessing the XML file isn't picked up?

By the way, in the Outlook VBA I added the Microsoft XML, 3.0 as reference

Anyone has a clue what I am doing wrong here?

MS Access 2010 - How can I tie an entry text box to a VBA command that opens a MS Word file based on user's entry?

Option Compare Database

Function Openword(conPath As String)
Dim appword As Word.Application
Dim doc As Word.Document

On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Set doc = appword.Documents.Open(conPath, , True)
appword.Activate

Set doc = Nothing
Set appword = Nothing




End Function

Private Sub Command5_Click()
Dim mydoc As String
mydoc = "J:\3 - Client Services\Nestle\1-Programs\12229709.docx"
Call Openword(mydoc)
End Sub

So far I have made the code that will open a specific file when the button on the form is clicked. However, there are a ton of these files that the user needs to be able to select and open. To keep it simple, I want them to be able to open the Word file by simply typing in the name of the file and clicking a button that will find and open it. The name of the file in the example above is simply 12229709.docx, but there are other files similar to it (e.g. 12172029, 12124057...) all in the same location. I want there to be a text box where the user can enter in the number and the button will check that specific folder for a file name with that number in it (without having to add the ".docx" if possible). How do I go about doing this?

MS Access create multi level subfolders

How can I programmatically create multiple levels of subfolders in VBA for MS Access? I know that MKDir only allows me to create one level, but I want to create 2 levels. The first level folder is based on the year the shipment took place, then the sub-level folder to that is the shipment number. The idea is to check and see if a folder(s) exists, and if not to create and open them.

Here is what I have so far:

Private Sub Command173_Click()
 Const strParent = "S:\shipments\"
 Dim strYearEntered As String
 Dim strEntryNumber As String
 Dim strFolder As String
 Dim fso As Object
 strYearEntered = Me.YearEntered
 strEntryNumber = Me.EntryNum
 strFolder = strParent & strYearEntered & "\" & strEntryNumber
 Set fso = CreateObject("Scripting.FileSystemObject")
 If fso.FOLDEREXISTS(strFolder) = False Then
     fso.CreateFolder strFolder
 End If
 Shell "explorer.exe " & strFolder, vbNormalFocus

End Sub

Using this code gives me an error at the "fso.CreateFolder strFolder" line. This problem only occurred when I placed the "\" in the strFolder line, without the "\" it will only create one folder by cramming together the YearEntered and EntryNum values. Can anyone assist in this matter?

Thanks.

Runtime error 462 Excel VBA using Word

I keep getting the 462 error the second or third time I run this loop. I don't think I have any objects that are floating but maybe I missed something, I am kind of new at this. This macro is taking all the charts from Excel, pasting them into Word as pictures, resizing them, saving the document and closing it. The For loop has formatting for the chart to be pasted as a normal picture and the text below it to be caption so I can create a figure table easily.

The error takes place in the .Height = InchesToPoints(6.1) line.

Private Sub ChartstoWord_Click()

Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i As Long


Application.ScreenUpdating = False

If wordfile.Value = "" Then
    MsgBox "Please enter a word file name", vbOKOnly
    Exit Sub
End If

wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)

'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
    Set WDApp = CreateObject("Word.application")
    WDApp.Visible = True
    Set WDDoc = WDApp.Documents.Add
    WDApp.Visible = True
    With WDDoc
        .SaveAs wfile
        .Close
    End With
    Set WDDoc = Nothing
    WDApp.Quit
    Set WDApp = Nothing
End If

' Create new instance of Word and open filename provided if file exists
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
WDApp.Visible = True

Set WDDoc = WDApp.ActiveDocument

With WDDoc
  .Range(start:=.Range.End - 1, End:=.Range.End - 1).Select
  .PageSetup.Orientation = wdOrientLandscape
End With

For n = 1 To Charts.Count

Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture

' Paste chart at end of current document

WDApp.Visible = True

With WDApp

.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
.Selection.Font.Size = 12
.Selection.Font.Bold = True
.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
.Selection.TypeParagraph
.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Selection.Font.Size = 12
.Selection.Font.Bold = False
.Selection.TypeText (wordname + " " + cname)
.Selection.TypeParagraph

End With

Next n

'resize all pictures
WDApp.Visible = True
With WDApp

With WDDoc
    For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
        With WDApp.ActiveDocument.InlineShapes(i)
            '.Width = InchesToPoints(7.9)
            .Height = InchesToPoints(6.1)
        End With
    Next i
End With
End With

WDDoc.Save
WDDoc.Close
Set WDDoc = Nothing

WDApp.Quit
Set WDApp = Nothing

Worksheets("Control").Activate
Range("A1").Select

Application.ScreenUpdating = True
End Sub

EXCEL - Split cell contents to additional/duplicate rows

Good morning,

I am looking for some assistance in creating some VBA code that can take a customer record, where 1 cell contains multiple items and split those items out into additional/duplicate rows.

I have found a project that essentially does what I am looking for, but due to my lack of programming knowledge, I have not been able to get it to work with my data - Split comma separated entries to new rows

Example Data http://ift.tt/1H8tjb0

The column that contains the data I want to split is column K. Each item is separated by “, “. I also need to retain any leading zeros in the data.

I’d like to have the script determine the number of items in K, duplicate the data A thru J on the duplicate lines and then take the items from K and put them into their individual lines. (see “Ideal Result” sheet in the Example Data File)

Any help on this is greatly appreciated!

Ian

Efficiently transfer Excel formatting data to text file

Here it is, I have a huge Excel workbook with which users write pricing quotes. On save, rather than saving the huge workbook, I'm transferring the relevant data to a text file and saving that text file. It's going off without a hitch, except for the one worksheet that contains formatting. I don't want the user to lose formatting when they load the previously saved quote (from the text file), so I need to determine a way to transfer that formatting data to and from the text file. Is there a smart way to do this without writing hundreds of lines of code or using any non-native Excel feature?

Here's a sample of the code for other sheets, but it's not much help for what I'm trying to do:

Sub WriteQuote()

Dim SourceFile As String
Dim data As String
Dim ToFile As Integer
Dim sh1, sh2, sh3 As Worksheet

Set sh1 = Sheets("sheet 1")
Set sh2 = Sheets("sheet 2")
Set sh3 = Sheets("sheet 3")

SourceFile = "C:\Users\███████\Desktop\test.txt"
ToFile = FreeFile

Open SourceFile For Output As #ToFile

'PRINT DETAILS TO TXT FILE
For i = 7 To 56
If sh1.Range("B" & i).Value <> "" Then
    data = sh1.Range("B" & i).Value & "__"
    If sh1.Range("D" & i).Value <> "" Then
        data = data & sh1.Range("D" & i).Value & "__"
    Else: data = data & " __"
    End If
    If sh1.Range("E" & i).Value <> "" Then
        data = data & "ns" & "__"
    Else: data = data & " __"
    End If
    data = data & sh1.Range("F" & i).Value & "__"
    data = data & sh1.Range("G" & i).Value & "__"
    data = data & sh1.Range("J" & i).Value & "__"
    data = data & sh1.Range("M" & i).Value
Else: Exit For
End If
Print #ToFile, data
Next i
Close #ToFile
End Sub

Overflow error in VBA

I am getting an overflow error in the following piece of code:

Sub Button3_Click()
Dim inc As Integer
Dim i, j As Integer

Dim sem_new As Double
Dim aff_new As Double
Dim imu_new As Double


'Initialising Lever variables
 sem_new = Sheets("Front end").Range("C6").Value
 aff_new = Sheets("Front end").Range("D6").Value
 imu_new = Sheets("Front end").Range("E6").Value
 'Initializing increment variable
 inc = 1
 If Sheets("Control Sheet").Range("D5").Value = "Overall" Then
 MsgBox ("Overall")
 Else
 For i = 8 To 408
 j = 3
 sem_new = sem_new + 10000
 aff_new = aff_new + 10000
 imu_new = imu_new - 10000
 ****Sheets("Front end").Select
 Sheets("Front end").Cells(i, j).Value = ((Sheets("Front end").Range("F6").Value * ((sem_new / Sheets("Front end").Range("C6").Value) ^ Sheets("Front end").Range("H6").Value) * Sheets("Front end").Range("K6").Value) - (Sheets("Front end").Range("F6").Value * Sheets("Front end").Range("K6").Value)) / (inc * 10000)****
 j = j + 1
 Sheets("Front end").Cells(i, j).Value = ((Sheets("Front end").Range("F6").Value * ((aff_new / Sheets("Front end").Range("D6").Value) ^ Sheets("Front end").Range("I6").Value) * Sheets("Front end").Range("K6").Value) - (Sheets("Front end").Range("F6").Value * Sheets("Front end").Range("K6").Value)) / (inc * 10000)
 j = j + 1
 Sheets("Front end").Cells(i, j).Value = ((Sheets("Front end").Range("F6").Value * ((imu_new / Sheets("Front end").Range("C6").Value) ^ Sheets("Front end").Range("J6").Value) * Sheets("Front end").Range("K6").Value) - (Sheets("Front end").Range("F6").Value * Sheets("Front end").Range("K6").Value)) / (inc * 10000)
 inc = inc + 1
 Next i
 End If

 End Sub

The code runs fine for 3 iterations but throws an overflow error on the fourth iteration.None of the numbers being used in the formula are beyond millions.The line at which the error comes is highlighted below.Any help would be appreciated

How to fix #VALUE! when UDF references another workbook

I have defined a function in the Module1 of my workbook that looks like this:

Function Header(r As Range) As String
    For i = 1 To r.Row
        If r.Offset(-i, -1).Value = "" Then
            Header = r.Offset(-i).Value
            Exit For
        End If
    Next
End Function

and I call it with a reference to another workbook's cell like this:

=Header('[OtherWorkbook.xlsx]Sheet1'!C34)

and what I get is #VALUE!... until, I open the other workbook, at which point the value magically appears.

how can I force the spreadsheet to fetch the values from the other workbook, even though it isn't open?

Excel VBA to Export Data to MS Access Table - Extended

I'm trying to use the method that was described in one of the other threads that I saw posted on stackoverflow here.

When using the method that was described in that thread (that got the green check) I'm getting an error when running the code. The error pop-ups up a blank message box with no contents.

A couple of things to mention:

(1) I've made sure to select and activate the Microsoft Access 14.0 Object Library in Excel.

(2) I am running the sub procedure from my database worksheet in Excel.

(3) I am then running the AccImport procedure within my code procedure from my wizard worksheet in Excel (separate worksheet).


EXCEL SPREADSHEET SETUP

I can't use screenshots as of yet as I am new to the community but the database worksheet field range is setup as follows.

B1 (Occurrence Date), C1 (Machine), D2 (Cell), E2 (Status), F2 (Issue), G2(Preventative/Corrective), H2 (Assigned To)

B2 (15-APR-2015), C2(machine1), D2(cell1), E2 (0), F2(Test), G2 (Corrective), H2 (nameexample1)


ACCESS DATABASE TABLE IS SETUP AS FOLLOWS:

Table Name: MaintenanceDatabase

ID, Occurrence Date, Machine, Cell, Status, Issue, Preventative/Corrective Assigned To

Here is the code that I am running from the Database worksheet in Excel:

Sub AccImport()

    Dim acc As New Access.Application
    acc.OpenCurrentDatabase "C:\Users\brad.edgar\Desktop\DASHBOARDS\MAINTENANCE\MaintenanceDatbase.accdb"
    acc.DoCmd.TransferSpreadsheet _
        TransferType:=acImport, _
        SpreadsheetType:=acSpreadsheetTypeExcel12Xml, _
        TableName:="MaintenanceDatabase", _
        Filename:=Application.ActiveWorkbook.FullName, _
        HasFieldNames:=True, _
        Range:="Database$B1:H2"
    acc.CloseCurrentDatabase
    acc.Quit
    Set acc = Nothing

End Sub

Code Snippet from other Worksheet Object that Runs AccImport:

Public Sub DeleteSelectedRecord()
    Dim CurrentSelectedIndex    As Integer

    ' Assign the currently selected index to CurrentSelectedIndex
    CurrentSelectedIndex = [Database.CurrentIndex]

    ' Move the ListBox Selector
    If [Database.CurrentIndex].Value = [Database.RecordCount] Then    
'Last item on the list
        [Database.CurrentIndex].Value = [Database.CurrentIndex].Value - 1
    End If

    'Copy to Access Database

    Database.AccImport

    ' Delete the entry
    Database.ListObjects("Database").ListRows(CurrentSelectedIndex).Delete

End Sub

Hopefully someone could shed some light into why I'm getting an error.

Thanks in advance for any help.

Cheers,

Brad

Pulling website tables into worksheet

I am having a real hard time finding a way to pull tables off the website to excel. The website that i have access to has a login system with a one time password (OTP) which will be sent to my mobile. Is there a way to do it so that i can automate the login and pause for me to enter my OTP then continue the pulling?

I have tried pulling tables off other open websites but this OTP is making it really difficult to work around.

Using .AddItem With Different Comboboxes in Excel VBA Userform

I have a userform with a lot of comboboxes. I am trying to use .AddItem when the userform is intialized, with no success.

Here is what I have tried so far:

Sub Userform_Initialize()
  Dim cCont As MSForms.ComboBox

  For Each cCont In Me.Controls
    cCont.AddItem "Item Added"
  Next cCont
End Sub

I usually get a runtime error 13 "type mismatch" come up. Not sure if that has anything to do with the button I have on the userform as well.

How do I loop through a userform and use .AddItem to each combobox? Once I get the code on how to do this, I'll wrap it in an If statement to only add it to certain comboboxes with certain words in the name, if that helps for context.

Thanks in advance,

-Anthony

Extract string from multiple files using vba

I need to extract a data from a set of text files inside a folder. I tried several times without success, I hope that someone can help me.

All the files I have to read are inside the folder C:/test. The data I need to extract from text file is located after a key word. The data should be placed in an excel file (every data copied from a single text file inside a different cell).

I tried with this macro, but it doesn't work:

Dim myFile As String, myFolder As String, text As String, textline As String, originatorName As String, entryDescription As String, amount As Long

Sub Button1_Click()

Dim fs, f, f1, fc

Dim cella

cella = A2

    'Add column headers

Range("A1").Value = "Brightness"

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("C:\prova")
Set fc = f.Files
For Each f1 In fc
    If InStr(1, f1.Name, ".txt") Then

'Open file
Open f1 For Input As #1

Do Until EOF(1)
    Line Input #1, textline
    text = text & textline
Loop

'Close file
Close #1

ReadBRTLuminance = InStr(text, "Read BRT Luminance")

ActiveCell.Offset(cella, 1).Value = Mid(text, ReadBRTLuminance + 31, 9)
cella = cella + 1

End If

Next


End Sub

I wrote a macro to extract the data I need from a single file (and it works fine). The keyword is Read BRT Luminance and the macro is:

Dim myFile As String, myFolder As String, text As String, textline As String, originatorName As String, entryDescription As String, amount As Long

Sub Button1_Click()

'Add column headers
Range("A1").Value = "Brightness"


'Show open file dialog box
myFile = Application.GetOpenFilename()

'Open file
Open myFile For Input As #1

Do Until EOF(1)
    Line Input #1, textline
    text = text & textline
Loop

'Close file
Close #1

ReadBRTLuminance = InStr(text, "Read BRT Luminance")

Range("A2").Value = Mid(text, ReadBRTLuminance + 31, 9)

End Sub

VBA: How to transform a one column full dictionary into one column per letter?

I have a full dictionary. All the words (360 000) are in one column.

I'd like to have Column B with all words starting with "a", column C with all words starting with b...

I am trying to do a loop or something... but... It is just too long.

Any tips? Or did someone already do this vba macro?

Tks,

Stéphane.

Generating String from Excel Sheet

I have an excel with three columns and three rows like below:

Field1,Field2,Field3

Row1Value1,Row1Value2,Row1Value3

Row2Value1,Row2Value2,Row2Value3

Row3Value1,Row3Value2,Row3Value3

I want to write a VBA Macro to generate an output like below:

Field1=Row1Value1,Field2=Row1Value2,Field3=Row1Value3
Field1=Row2Value1,Field2=Row2Value2,Field3=Row2Value3
Field1=Row3Value1,Field2=Row3Value2,Field3=Row3Value3

Is there an easy way to do this?

Excel merging two files based on a variable

I want to write a program that will match variable names in two separate workbooks, than copy all information from variable until page break from both workbooks into a new work. Each workbook has multiple pagebreaks not sheets. For example:

Workbook A (Variable = X)    
Persons          Name  
X                    Bill  

Work Book B  
Persons          Nickname  
X                   Billy  

New Workbook  
Page 1  
Persons          Name  
X                   Bill  

Page 2   
Persons          Nickname  
X                  Billy  

I was using the code at this site to merge the two selected workbooks, but I cannot figure out how to match by name and than copy to page break. Can anyone have suggestions or can help direct me? Thank you!

Create power point using excel macro

I have an interesting problem I am unsure of. I have not worked with power point and have little excel macro experience. I have found many similar issues to mine but none of them quite fit the bill. I am helping my local charity with a fund raiser and need a way to make a triva sort of game. The game will be displayed with powerpoint, and all the questions, choices, and answers are in an excel sheet. The way it is laid our is one question per row, and the columns are: Question, options, answers and category.

I have managed the category sorting quite easy enough, but now I need to somehow work with creating power point slides in such a way so that the question is the title, with the options being the content, and then the following slide is the answer to that question. Therefore each question creates two slides, a question and answer slide.

Example row (| denote column):

Which of these was an italian sculptor? | Michelangelo, tintoretto, da vinci, galilleo | michelangelo | Art

So the result would be a side with title "Which of these was an italian sculptor?" and content a) Michelangelo, b) tintoretto, c) da vinci, d) galilleo

the following slide simply being "Michelangelo"

Hide/Show newly created tab in Microsoft Excel

I am new to VBA Script. I am using excel 2010 version. I am trying to create a new Tab(Ex:Trends) beside Data tab. I want to show/Hide Tab(Trends) based on the column selected. If I select Column A,the tab(Trends) should show and if i select column B the tab(Trends) should hide.

How I can achieve the above functionality? Do we need a macro to achieve this or any alternative.enter image description here

On error Scope VBA

What happens if an error occurs inside the sub two. Will it resume next?

Sub One()

  On Error Resume Next
  call Two

end sub

Thanks!

Automatic add reference to VBA Excel macro via c#

I add a macro by c# code to excel for running stored procedure and execute it but becuase it has not refrence of ActiveX Data Objects 2.5 library gets an error "complie error : user-defined type not defiend " when i add that refrence manualy it will be ok but i want to add it via code because user cant refrence it.

then I need to programaticly check the users PC to see if a reference to

Microsoft ActiveX Data Objects 2.5 Library or later

Exists and if it does not, create it by C# code or VBA code in my macro

E-Mail body is lost when sending (outlook vba)

I'm trying to write a macro that sends an automatic notification to specific addresses (kind of like a cc, but then without actually using cc) before sending the original email. The content of the original (formatted) email (including text, tables and pictures) should be copied and pasted into a new email which is then automatically sent. everything is works when just displying, but not when actually sending the email. the code is as follows:

Dim objMsg As Outlook.MailItem
Dim activeMailMessage As Outlook.MailItem
Dim BodyText As Object

' Create the message.
Set objMsg = Application.CreateItem(olMailItem)

'copy body of current item
Set activeMailMessage = ActiveInspector.CurrentItem
activeMailMessage.GetInspector().WordEditor.Range.FormattedText.Copy

'paste body into new email
Set BodyText = objMsg.GetInspector.WordEditor.Range
BodyText.Paste

'set up and send notification email
With objMsg
    .To = "test@domain.com"
    .Subject = "text" 
    .Send
End With

it was hard enough to find out how to do this to begin with, as pasting the text into the body like this:

With objMsg
    .To = "test@domain.com"
    .Subject = bodytext.paste 
    .Send
End With

would not paste any of the text at all (for no obvious reason to me).

when i use

    .display  

the right content is displayed, but when i send it, all of a sudden all information is lost and an empty email is sent. what can i do?

PS i realize i could add a bcc in the original email to achieve the same result, but the original email is not always send, whereas the notification should be.

VBA increasing dynamic range in VLOOKUP

I'm having trouble with setting properly dynamic range for VLOOKUP which should be increasing by 58 with each loop (I have 96 different ranges). VLOOKUP table is in other ("Gefco") sheet. The error I'm getting is:

Application-defined or object-defined error

Code:

Sub vlookup_rates()

Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim e As Long
Dim rr, dupa As Range
Dim ws, wws As Worksheet
Dim wb As Workbook


c = 1
a = 2
b = 59
d = 2
e = 59

Set wb = ActiveWorkbook
Set ws = wb.Sheets("Gefco")
With ws
Set rr = Range(Cells(d, 4), Cells(e, 8))
End With

Set wws = wb.Sheets("Waberers")
wws.Activate

    Do While c < 97
        Cells(4, a).Select
        Cells(4, a).Formula = "=VLOOKUP($A$4;" & rr.Address & ";5;0)"  <-ERROR

        c = c + 1
        a = a + 1
        b = b + 1
        d = d + 58
        e = e + 58

    Loop
End Sub

I think range is somehow wrongly defined but I can't crack it. Please halp.

Thanks!

Split function isn't recognising white space from text copied from internet page source

I've set up a function to process data copied and special pasted (value only) onto my worksheet.
The data in question is a name "John A Smith"

And my method is

Dim vFullName As Variant
Let vFullName = Split(sName, " ")

When I split the pasted string, I only get 2 arrays; [0] John & [1] A Smith
If I enter the data myself I get the expected 3 arrays; [0] John, [1] A & [2] Smith

I can't understand why the pasted string isn't splitting completely. Can anyone tell me why the second space isn't being registered.
The Spaces are physically there.

Cheers

Turning the visibility of chart series on/off using excel Macros/vba

I am making a line graph (chart) in Excel with several data series being plotted onto the same chart.

I need to create a macro/VBA solution that can turn the visibilty of these series on/off via the pressing of a button (or tick box etc)

Similar to this picture (manually done through the excel menu system)

enter image description here

I have tried to look through all the member vars/methods on

http://ift.tt/1NXFN9q

but haven't had much luck.

I have tried playing around with bits like

Charts("Chart1").SeriesCollection(1)

and

Worksheets("Graphical Data").ChartObjects(1)

but I can neither get the chart object ( I get a subscript out of range error) nor able to find any method that would allow me to turn on/off the visibility of individual series.

Any Ideas?

Placed a button and named as backspace,when clicked button should act as actual backspace on a textbox

I am creating a multilanguage keyboard using vba excel 2007,I have added buttons to display the character in a textbox ,so If i want to type A then i have written code as

Private Sub CommandButton88_Click() 
 TextBox1.Text =  ChrW(65) 
End Sub

Now I have placed a button for backspace,another for enter,another for escape ,f1,etc...But how to write codes if I want the button named backspace to work exactly as backspace button in actual keyboard and enter as enter and so on....

Please reply,seen keyascii and application.sendkeys({backspace}),but how to apply it on the textbox to work as backspace,enter etc...please reply, for backspace found as chr(8),but how to apply?

VBA SelectSingleNode xpath with multiple namespace

I have simillar problem to others trying to search with xPath through XML with two namespaces but still looking on other topics it dosen't seem to work:

XML:

<?xml version="1.0" encoding="utf-8"?>
<IE515 xmlns:ds="http://ift.tt/uq6naF" xmlns="http://ift.tt/1JmkIyZ" NrWlasny=""
   EmailPodmiotu="">
   <Zgloszenie UCWywozu="" UCWyprowadzenia="PL441010"
      P1a="EX" P1b="A" LiczbaPozycji="" LiczbaOpakowan="" CRN=""
      KrajWysylki="" KrajPrzeznaczenia="" Kontenery="0" MasaBrutto="">
      <Nadawca TIN="" Nazwa="" UlicaNumer="" KodPocztowy="" Miejscowosc=""
         Kraj="" EORI=""/>
      <Odbiorca Nazwa="" UlicaNumer="" KodPocztowy=""
         Miejscowosc="" Kraj=""/>
      <ZglaszajacyPrzedstawiciel KodPocztowy=""
         Miejscowosc="" Kraj="" Nazwa="" TIN="" EORI="" UlicaNumer=""
         Wskaznik="00300" Przedstawicielstwo="1"/>
      <TransportWewnetrzny
         Rodzaj="5"/>
      <TransportNaGranicy Rodzaj="4" Znaki="SAMOLOT"
         Kraj="DE"/>
      <Lokalizacja UC=""/>
      <WarunkiDostawy Kod=""
         MiejsceKod="" Miejsce=""/>
      <Transakcja Waluta="" Wartosc=""
         Kurs=""/>
      <MiejsceData Miejsce="" NazwiskoImie="" Telefon=""
         Data=""/>
      <Towar Nr="1" OpisTowaru="TestName" KodTowarowy="30000" KodTaric="00"
         KrajPochodzenia="PL" ProceduraWnioskowana="10"
         ProceduraPoprzednia="00" MasaNetto="1.4">
         <IloscTowaru Jm="NAR"
            KwalifikatorJm="G" Ilosc="8"/>
         <Opakowanie Rodzaj="PA" Znaki=","
            LiczbaOpakowan="2"/>
         <KodDodatkowyUE Kod="4099"/>
         <DokumentWymagany
            Kod="9DK8" Nr="Oswiadczenie"/>
         <DokumentWymagany Kod="N380"
            Nr="OUT1"></DokumentWymagany>
         <DokumentWymagany Kod="Y903"
            Nr=","/>
         <DokumentWymagany Kod="Y935" Nr=","/>
         <DokumentWymagany
            Kod="Y922" Nr=","/>
         <InformacjaDodatkowa Kod="30400"/>
         <WartoscTowaru
            Waluta="PLN" WartoscStatystyczna="953">
            <Korekta Kod="1STW"
               Wartosc="-200"/>
         </WartoscTowaru>
      </Towar>
   </Zgloszenie>
</IE515>

in my code I'm trying to set NameSpace propoerty like this:

xmlNameSpaces = "xmlns='http://ift.tt/1JmkIyZ' xmlns:ds='http://ift.tt/uq6naF'"
doc.setProperty "SelectionNamespaces", xmlNameSpaces

and then try to search for the specific node, but it dosen't find the node:

Set oAttribute = doc.SelectSingleNode("/IE515/Zgloszenie/Towar[1]/@OpisTowaru")`

Can you explain how the namespace propperty should look like to make it work? I can do this if I have onl

Adjust rows with the same value (e.g. date) to be in the same column in Excel

I've got a spreadsheet with columns, that has values (e.g. dates) in the first row. There are many pairs of rows, that has dates in the first row with values assigned to them in the second row. Everything is clearly visible in screenshots.

How to adjust those values to the reference dates (from the first row)?

I was thinking about some VBA macro, but it's beyond my skills.

Current State: http://ift.tt/1DPr8GM

Desired State: http://ift.tt/1aD7QZz

Get the data from excel files in directory

I am a newbie here, but found superb solutions from the members of this forum. What I´m looking for is to get data from excel files in specific directory. What I found here was awesome, and helped me to partially solve my problem, but not the whole thing.

Get the data from excel files in sub directories

I need to get data from various excel files in specific directory. Here I found vba script that is making almost the thing I need, except 2 thing: 1. It gets data from every excel file found in directory, I only need data from files containing specific sheets. The files are detailed information about projects, information are updated weekly, so every sheet in the file is named by the abbreviation CW (means calendar week), space and number of the week. Different projects run different weeks. The folder is basically month summary. So the project one keeps running from week 2 up until week 8, another one from week 1 til week 5 and so on. From this you can see, that when I have, for instance 8 files in the folder, relevant information and the given week containing for example 5 files. The script doesn't recognize it and it gives something like !N/A result for the weeks, that are not in given files. Is it possible to adjust it, that only flies with those specific sheets would be processed? 2. I need to format the values, from one of them i need left 2 characters, from another one 4 right characters, another 3 i need get divided by 1000. If I put these conditions into the script, I think, that because of the !N/A results, it stops working...

Does anybody have solution for that?

Thanx in advance.

SUM formula vba code

How is it possible to sum two columns in an excel file into another column. I want to sum Column A with Column B and the result should be shown in column C, but how can I do it in vba?

For example:

Col A.

  1. 1
  2. 2
  3. 3

Col B.

  1. 1
  2. 2
  3. List item

Col C.

  1. 2
  2. 4
  3. 6

Run Excel VBA module for all the values of a Combo Box

I want to run a macro in Excel 2010 that uses each of the values in a combo box automatically until all the values in the combo box have been run.

For example if the combo box has the values 1,2,3,4 the code should run for each of these values passing them into a macro.

I need a macro that will check new entries if it is already existing or it is within the range of an existing entry

I have 2 files with name NewEntries.CSV and Existing.CSV

Header A1(Company Code), B1(PurchaseOrg),C1(TransactionType),D1(CommodityCode),E1(MinTC),F1(MaxTC)

how will I implement this condition to check the New Entries and copy same or within the range entries in a new file or sheet.

IF [NewEntries(A1,B1,C1,D1) = Existing(A1,B1,C1,D1:A*,B*,C*,D*)] & [NewEntries(E1)>= Existing(E*) OR NewEntries(F1)<= Existing(F*)]

How to automate login which is related to onmouseup in html page using VBA?

I tried using class name and click option but it didn't work.

<div class="rbBC rbBFC rbB"> awmouseup = true
    Log In
</div>

This is the code available in the html page. How to automate in VBA that should click automatically login that has no button and name and id.

Excel VBA: adding a row to a variant array in one line

I´d like to add a row to a variant array:

Dim arrMod As Variant
arrMod(numberOfRow) = Array(myValue1, myValue2, myvalue3)

The execution of this code results into an exception: Error 13: type mismatch How can I do it without iterating each column?

Thanks,

Regards

every possible combination of the contents of 2 columns in excel

Suppose I have 2 Columns:

1st column(contains 1000 rows):

U-0001

U-0002 

2nd column(contains 10 rows):

B01

B02

B03

Now, I want to generate two columns like this(with 10*1000 = 10000 rows):

U-0001 B01

U-0001 B02

U-0001 B03

U-0002 B01

U-0002 B02

U-0002 B03

Loop does not recognize Do

I have been editing/writing this code to merge multiple workbooks into one. However I get a "Loop without Do" compile error. The possible duplicate does not say what went wrong, only gives a new code, so that is not a answer to my question but a solution.

Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim OCol As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRangeCult As Range
    Dim DestRangeCult As Range
    Dim SourceRangeYield As Range
    Dim DestRangeYield As Range
    Dim SourceRangeLoc As Range
    Dim DestRangeLoc As Range
    Dim SourceRangeDRipe As Range
    Dim DestRangeDRipe As Range
    Dim LastRow As Integer
    Dim LastColumn As Integer
    Dim col As Integer

    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    FolderPath = "M:\My Documents\MSC Thesis\United Kingdom\Winter Barley\Merge excel\"

    NRow = 1
    OCol = 2
    OColD = OCol + 48


    FileName = Dir(FolderPath & "*.xl*")


        Do While FileName <> ""

            Set WorkBk = Workbooks.Open(FolderPath & FileName)


            SummarySheet.Range("A" & NRow).Value = FileName


            LastRow = ActiveSheet.UsedRange.Rows.Count
            LastColumn = ActiveSheet.UsedRange.Columns.Count

                For col = 2 To 49

                Set SourceRangeLoc = WorkBk.Worksheets(1).Range("A1:A" & LastRow)
                Set DestRangeLoc = SummarySheet.Range("C" & NRow)
                Set DestRangeLoc = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)

                Set SourceRangeCult = WorkBk.Worksheets(1).Range(OCol & "1:" & OCol & "1")
                Set DestRangeCult = SummarySheet.Range("B" & NRow)
                Set DestRangeCult = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)

                Set SourceRangeYield = WorkBk.Worksheets(1).Range(OCol & "2:" & OCol & LastRow)
                Set DestRangeYield = SummarySheet.Range("D" & NRow)
                Set DestRangeYield = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)

                Set SourceRangeDRipe = WorkBk.Worksheets(1).Range(OColD & "2:" & OColD & LastRow)
                Set DestRangeDRipe = SummarySheet.Range("E" & NRow)
                Set DestRangeDRipe = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)


                DestRangeCult.Value = SourceRangeCult.Value

                Exit For

                NRow = NRow + DestRange.Rows.Count
                OCol = OCol + 1

            WorkBk.Close savechanges:=False

            FileName = Dir()

        Loop

    SummarySheet.Columns.AutoFit

End Sub

Excel VBA Aggregate Function Error

I am new to Excel VBA. When I run the below code, I get an error "missing operator in query expression sum[Project Hrs]". What am I doing wrong?

Sub TaskHrs()

   strSQL = "Select [User Name], [Task Name], sum[Project Hrs] from [idata$]      group by [User Name], [Task Name]"

   closeRS
   OpenDB

   rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic

  If rs.RecordCount > 0 Then
   Do While Not rs.EOF
     Range("A1").CopyFromRecordset rs
   Loop
  End If


End Sub

Automation of IE via VBA executes as intended, but throws an automation error

I have the following code, which is supposed to open Internet Explorer in order to download a file.

Sub hentRapport()
  Dim IEapp As Object
  Dim WebUrl As String

  Set IEapp = CreateObject("InternetExplorer.Application") 'Set IEapp = InternetExplorer
  WebUrl = Oversikt.Range("Adresse")

  With IEapp
    .Silent = True 'No Pop-ups
    .Visible = True 'Set InternetExplorer to Visible
    .Navigate WebUrl 'Load web page

    'Run and Wait, if you intend on passing variables at a later stage
    Do While .Busy
        DoEvents
    Loop

    Do While .ReadyState <> 4
        DoEvents
    Loop
  End With
End Sub

Internet Explorer (IE 11.0.9600.17691) opens as expected, and I get up the dialog for downloading the file, but at the same time I get an error from the macro:

enter image description here

The error happens on the line

Do While .ReadyState <> 4

and I can't figure out why. Doesn't that line simply state that Excel doesn't need to wait for IE to do its thing before accepting other input?

Excel, comparing two specific rows in two sheets and highlighting the differences

Before commenting on saying that there are similar questions, Ive tried them but they do not work unfortunately

Hi, this is the first time I am on S.O, rest assured, I have spent hours looking for a solution for this. I have a status column which shows statuses such as, deleted, new, changed. When the status is "changed", I would like to compare that particular row from column E to the last possible column in Excel (XFD) in Sheet3 to columns A to the last possible column in Excel (XFD) in Sheet1 and highlight the cells which are different.

I have found this solution:-

Dim diffB As Boolean
  Dim r As Long, c As Integer, m As Integer
  Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
  Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
  Dim rptWB As Workbook, DiffCount As Long
  Application.ScreenUpdating = False
  Application.StatusBar = "Creating the report..."
  Application.DisplayAlerts = True
  With Sheet1.UsedRange
    lr1 = .Rows.Count
    lc1 = .Columns.Count
  End With
  With Sheet3.UsedRange
    lr2 = .Rows.Count
    lc2 = .Columns.Count
  End With
  maxR = lr1
  maxC = lc1
  If maxR < lr2 Then maxR = lr2
  If maxC < lc2 Then maxC = lc2
  DiffCount = 0
  For c = 1 To maxC
    For i = 2 To lr1
      diffB = True
      Application.StatusBar = "Comparing cells " & Format(i / maxR, "0 %") & "..."
        For r = 2 To lr2
          cf1 = ""
          cf2 = ""
          On Error Resume Next
          cf1 = Sheet1.Cells(i, c).FormulaLocal
          cf2 = Sheet3.Cells(r, c).FormulaLocal
          On Error GoTo 0
          If cf1 = cf2 Then
            diffB = False
            Sheet1.Cells(i, c).Interior.ColorIndex = 19
            Sheet1.Cells(i, c).Select
            Selection.Font.Bold = True
            Exit For
          End If
        Next r

     If diffB Then
       DiffCount = DiffCount + 1
       Sheet1.Cells(i, c).Interior.ColorIndex = 0
       Sheet1.Cells(i, c).Select
       Selection.Font.Bold = False
     End If
    Next i
  Next c3
Application.StatusBar = "Formatting the report..."
'Columns("A:IV").ColumnWidth = 10
m = maxR - DiffCount - 1
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox m & " cells contain same values!", vbInformation, _
"Compare " & Sheet1.Name & " with " & Sheet3.Name

However, this compares columns and I do not know how to limit the comparison to column E-XFD in sheet1 to column A-XFD in sheet2.

There are also several sheets in this workbook but I only want to compare sheet1 and sheet2.

It will be much appreciated if you guys can help me out :)

Thanks!

Using ADO.NET in the IDE integrated in microsoft Excel

I want to build an authentification system based on an Excel spreadsheet database. Therefore I would like to know if it's possible to use ADO.NET in the IDE integrated in microsoft Excel. (I don't want to use visual basic studio)

Excel VBA: copy lots of columns

I´d like to copy all data from a Sheet to another sheet of another new Excel file. I have tried this:

Set wkb = Workbooks.Add
wkb.SaveAs myNewFile
ThisWorkbook.Worksheets("Sheet 2").Activate
Set Ticker = ThisWorkbook.Worksheets("Sheet 2").Range("A1").CurrentRegion
Ticker.Copy
wkb.Worksheets(1).Activate
Cells(1, 1).PasteSpecial xlPasteAll
wkb.Save
wkb.Close

The problem I´ve found is that it won´t work when there are a great amount of columns (for instance, from A to OV). Do you know other way to to this?

Adding filename while importing txt file in VBA

I just wrote a program that imports .txt files to excel.

I try to import the filename (custName) to the first row of the sheet and the .txt to start below that. My filename is imported lagging 2 columns behind the associated .txt file and the first imported filename is always missing.

Am I missing some sort of offset or is it something with how the first for loop is running?

Function import(shtraw)

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
    .Show
    .AllowMultiSelect = False
    If .SelectedItems.Count = 0 Then
        MsgBox "You did not select a folder"
        Exit Function
    End If
    MyFolder = .SelectedItems(1)
End With

Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
Set folderObj = fileSystemObject.getfolder(MyFolder)

shtraw.Select
For Each fileObj In folderObj.Files 'loop through files

If (fileSystemObject.GetExtensionName(fileObj.Path) = "txt") Then

    If Not fileObj.Attributes And 2 Then
        arrFileName = Split(fileObj.Path, "\")
        Path = "TEXT:" & fileObj.Path
        filename = arrFileName(UBound(arrFileName))

        'Get the filename without the.mtmd
        CustName = Mid(filename, 1, InStr(filename, ".") - 1)
        shtraw.range("$A$1").value = CustName

        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileObj.Path, Destination:=range("$A$2"))
            .name = filename
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    End If 'end if hidden if statement
    End If 'end of txt
Next fileObj 'close loop

range("$A$1:$B$1").Delete shift:=xlToLeft

End Function

Macro to check for duplicates in a column

Ive looked through the site and found a couple of example of code that looks for duplicates but they only match on partial case and not exact match.

I have a macro which takes a cell value and then looks in the column for any duplicates and increment a count for any it finds. However, it kind of works as it finds partial match duplicates but i need it to only match exact match duplicates.

For example currently if i have a row that contains a 1 and another row that contains an 11 it will highlight them rows as duplicated.

Here is the code i currently have.

Function CountMatches(searchvalue As String, sheet As Worksheet, r As String) As Integer

Dim firstFound As Range
Dim lastFound As Range
Dim matchCount As Integer
Set firstFound = sheet.Range(r).Find(searchvalue, After:=ActiveCell, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=True)

sheet.Range(r).Select

Set firstFound = sheet.Range(r).Find(What:=searchvalue, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)

If firstFound Is Nothing Then

  CountMatches = 0


Else

Do

        Set lastFound = sheet.Range(r).Find(What:=searchvalue, After:=IIf(lastFound Is Nothing, firstFound, lastFound), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)

      matchCount = matchCount + 1

   Loop Until lastFound Is Nothing Or firstFound.Address = lastFound.Address

  CountMatches = matchCount


  End If

End Function

find data in another workbook range return type mismatch error n.13

I have a problem with the following sub:

Sub prova()

Dim E As String

'Dim H As Range

'Dim G As String

E = range("D3").Value

range("F2").Select

'Set H = Worksheets("Sheet1").range("F3:F100")

range("F3:F100").find(What:=E, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate

End Sub

It returns a type mismatch error. The problem is related to the range where I want to search the variable E, either if I specify the range or I set it with a name (H). If I replace range(.....) with columns(6) or with cells (it searches in all the spreadsheet) it works. If I specify a range it doesn't work. I don't understand.

Excel VBA Transpose contiguous range each empty cell

I have an excel File with contiguous cells in rows separate by empty Rows ex : Name Adresse Tel Fax Web -- EMPTY ROW -- Name Adress1 Adress2 Tel Web -- EMPTY ROW -- ...

I need to take each contiguous range and transpose it in columns on the right of each range Actually i need to select the range by the hand and run a shortcut macro to transpose it with this code :

ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

Could you help me in vba to select a first range and transpose it then take the next range after the empty row and transpose it and again until the end of the file ?

Thanks in advance

vbmsgBox prompt is a mix of RTL(Persian) and LTR(English) but text is displayed in wrong order

I am designing a vba userform for excel 2013, in which I use English and Persian text, the problem is when I use a mix of both languages in a msgBox the bits of text come out in the wrong order, the number is supposed to be displayed at the end. here is the code:

Private Sub CommandButton1_Click()
   MsgBox "نام" & " - " & "نام" & " - " & "VF" & " - " & 52 & " ." _
   , 1 + 1048576 + 524288, "نام برگه"
End Sub

The parts in double quotes and the number are supposed to come from listBoxes.(I just replaced them here with examples, the code behaves the same) I tried spacing the bits out(works in windows), rearranging the bits and changing msgBox's alignment and reading order, but the result was the same. How to fix this thing?

dimanche 19 avril 2015

How to make an Excel function that include a pause without stalling Excel

I have an Excel "project" that includes a .dll where I have written some complex statistical calculations called through VBA. I have done that for speed reasons. The calculations take about a second each. Since they are called through VBA it stalls Excel for the duration of the calculations and that is acceptable. (The choice of Excel is not mine but a result of the way a third party has chosen to deliver data)


But for the purpose of the project I need to have the results of the calculations turn up after not three seconds but after ten. I could either expand the calculations for greater accuracy or simply include a pause in the code. But since it is done via VBA it stalls the whole project for all ten seconds and that is not acceptable.


I have looked into ExcelDNA since it avoids VBA completely and might make it possible to do ALL that is done via VBA with ExcelDNA or existing build in functions. I have modified this example for testing:


http://ift.tt/1Iw4MKl


and included a simple Thread.Sleep(10000); to the code to simulate the pause. But that ALSO stalls Excel for the duration of the calculation.


Is there a way to include a pause in functions that doesn´t make Excel wait for the result but where the result is "pushed" to the cell/the cell "subscribes" to the result? Can it be done via ExcelDNA, XLL or via a third solution? I would prefer a soution where I can use C or very lightly modified C since all the statistical functions are written in C.


Access vba select new raw in datasheet view

I have a datasheet view form. I want to add in it but when i set focus cause of sorting it select the top record which has data in it and edit it. Question is how I can select the new row which has * beside it, so when I set focus it will create a new record.


HOW TO SELECT THE NEW RAW OF A DATASHEET VIEW FORM WITH VBA CODE?


mistake in VBA timescaledata use for cost in Project

I have a little problem with small chunk of code. I want the code to show me monthly expenditures:



Dim TSV As TimeScaleValue
Dim TSVS As TimeScaleValues

Set TSVS = ActiveProject.Tasks(63).TimeScaleData( _
StartDate:=ActiveProject.ProjectStart, _
EndDate:=ActiveProject.ProjectFinish, _
Type:=pjTaskTimescaledCost, _
TimescaleUnit:=pjTimescaleMonths, Count:=1)
For Each TSV In TSVS
Debug.Print Val(TSV.Value)
Next TSV


Task(63) is actually a task that contains whole project and spans 22 months in this particular project. Yet the result in different projects are roughly the same: either one "0" or some cost that doesn't apply to the task. What's wrong with the code?


I wanted the program to give 22 values representing cost per month. I double-checked the task number, even referred to its name to be sure. Which leads to 2 other questions - is there a way to refer to a whole project instead of a task? And is the number (63 in this case) referring to unique Id? Sometimes program prompted me about "invalid argument" while clearly it wasn't.


Using Excel sheet to send emails and also to capture

I am managing a team of 8 quality analysts. Each of them has an Excel based tracker through which they audit various process gaps. All of them use the same tracker. What I want to do is: lets say there is a submit button in the tracker and once they fill in the tracker and click submit, an email should go the respective recipient and the data should be captured in a particular format in the master Excel file. Is this possible to do?


For Next Loop not working in VBA

So I've done SOME work with VBA in the past with moderate success, but am still very much an amateur. I am attempting to automate the pull of data from multiple pages of a website into a workbook. On one sheet titled "Events" I have 3 columns, the third of which (column C) is where I want the data pulled from, in the format "URL;http://ift.tt/1DrzSyj". I attempted to use the following code to go down my 108 rows, fetching all data:





Sub GetData()
For x = 1 To x = 108
ActiveWorkbook.Worksheets("Events").Select
ActiveWorkbook.Worksheets("Events").Activate
mystr = Cells(x, 3)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells(x, 2)
With ActiveSheet.QueryTables.Add(Connection:= _
mystr, Destination:=Range( _
"$A$1"))
.Name = "rankings"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next x
End Sub



unfortunately, upon running it, nothing happens. I've attempted to isolate it, and by setting x to any single number, it will work and create a single sheet. When attempting the run the loop however, as I said, I don't get a result. Any suggestions would be VERY appreciated.


BONUS question: I'm sure this wouldn't likely be TOO difficult, but if instead of creating individual sheets for each new import, I wanted the data from all webpages to go into the same sheet, how might I go about that? (All data will be in the same format, (that is to say, same number of columns, though the amount of rows differes from page to page.


Thank you so much for any help you can provide!


How do i add dashes till my cell value equals to five in vba

How do i add dashes(-) til my cell value = 5, If my length character is not equal to five and i have a 4 character, for ex A B... what i want it to do if i have cell value less then 5 then i want it to replace with dashes(-) till my cell length value reach to 5 character. Here is my Code and image... IMAGE will make more sense.. let me know if there is any confusion.enter image description here



Sub xn()
Dim x As Integer, lastrow As Long, a As Long, i As Long
Dim xcell As String
a = 1
lastrow = Worksheets("Sheet2").UsedRange.Rows.Count + 1
For i = a To lastrow
xcell = Worksheets("Sheet2").Range("A" & i).Value
Do Until Len(xcell) = 5
If Len(xcell) <> 5 Then
Worksheets("Sheet2").Range("C" & i) = Replace(xcell, " ", "_")
Else
Exit Do
End If
Loop
Next i
End Sub

Number of days in a month array visual basic

I'm working on a project where I enter a month of a year in a textbox and have it return (by pressing a button) the number of days that are in it. I must use a for each...next statement to search and match the strings between both arrays.


Here is what I have so far:



Dim monthname() As String = {"January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"}

Dim monthdays() As String = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}


For Each y As String In monthname
TextBox1.Text = (y)
Next


For Each x As String In monthdays
ListBox1.Items.Add(x)
Next



Dim search As String
Dim index As Integer = -1

For i = 0 To monthdays
If monthdays Is monthname Then
index = i
Exit For
End If
Next


I can't figure out how to make the arrays compare to one another when the name of the month is put in the textbox. Right now when it works the program just adds the last month (december) in the textbox and all the number of days into the listbox.


thanks for any help!