Free Microsoft Excel 2013 Quick Reference

Find string excel vba Results

Hello

This is not the basic find a string in a substring.

1. Column A (range A2:A167) contains values that contain characters and numbers (ex: ABC1230108)
2. Columns G:L contain strings that could contain one or more of the strings in Column A (Ex: ColA - A2: ABC1230108, A3 ABC1230208). Cols G:L (Lets say colG G49 contains ABC1230108-ABC1230808).

What I need to do is to have my vba know that ABC1230108-ABC1230808 includes ABC1230208, ABC1230308, ABC1230408 etc.

I then need Excel to write the values from Column A to a new worksheet.

I know this is a very tall order, but does anyone have a clue as to how to do this?

Thank you
Terry

All:

I am developing a VBA program that uses a barcode scanner in one application to read a printed barcode and then search from the Active Worksheet open in Excel. If the record
is found in Column J then I want to return the values from Column D and and Column J in the Active Row in order to use those values in the application.

So far, I have gotten the following code together that addresses most of these issues, but I seem to be missing something!

' This Function takes an alphnumeric barcode entry and declares
' it as NewValue. Column J of the Active Worksheet is searched
' for a corresponding value.

Private Sub Message001_ValueEntered(ByVal NewValue As String)
NewValue = ActiveSheet.Range("J2:J2000").Find.Value
End Sub

' If a match is found in the records, the SelectRow Function will
' select the row.

Function SelectRow()
Rows(ActiveCell.Row).Select
End Function

' Two values from the ActiveRow are required, the Tag2 sequence variable from
' Column D, and the Tag1 cell variable from Column F of the Active Row. The variables
' are declared.

Dim pCell As Integer
Dim pSequence As String
Dim Cell As Integer
Dim Sequence As String
Dim Tag1 As Integer
Dim Tag2 As String

' The FindCellValue function gives pCell the value of Column F in the Active Row.

Function FindCellValue(pCell)
Cells(ActiveCell.F).Select
End Function

' This declares the value of Cell equal to the pCell value.

Public Property Get Cell() As Integer
Cell = pCell
End Property

' This will set the value of pCell to the current cell value.

Public Property Let Cell(Value As Integer)
pCell = Value
End Property

' The FindSeqValue function gives pSequence the value of Column D in the Active Row.

Function FindSeqValue(pSequence)
Cells(ActiveCell.D).Select
End Function

' This declares the value of Sequence equal to the pSequence value.

Public Property Get Sequence() As String
Sequence = pSequence
End Property

' This will set the value of of pSequence to the current cell value.

Public Property Let Sequence(Value As String)
pSequence = Value
End Property

Much thanks for any help with this matter!

Hi all,
I keep running into an issue with my vba and Excel and can't figure it out.
My problem is I can't seem to to assign a cell value to a variable. I've included the code I am working on now below. I have tried various syntax for selecting the cell (commented lines below problem line), but everything returns a "Runtime Error 1004, Application-Defined or Object Defined Error".
With the snippet below I am basically trying to loop through some columns, get the last value
& compare to a trigger value, and create a string
that can then be passed to Outlook for mailing to a distribution.
The cell value lines are from another project & it worked fine there.
I have run into this on and off on other projects- clearly I am missing something... Any help would be greatly appreciated!

Using Excel 2002
Windows XP SP2
Code is in a macro, called by a form button

Sub EMAIL_RESULTS()
'*********NEW EMAIL TEST CODE START************************
'GET VALUES TO SEND TO USERS VIA OUTLOOK
'DEFINE VARIABLES
Dim myLASTrw 'LAST ROW WITH DATA IN IT
Dim myCOL 'CURRENT COLUMN
Dim myTRIGup 'UPPER TRIGGER VALUE FOR CURRENT COLUMN
Dim myTRIGlow 'LOWER TRIGGER VALUE FOR CURRENT COLUMN
Dim myTITLE 'COLUMN TITLE
Dim cellCOMMENTS 'COMMENTS IN THE LAST CELL
Dim myMESSAGE As String 'ASSEMBLED EMAIL SUBJECT
Dim myLASTval 'VALUE IN LAST CELL
Dim myTRIGcount 'COUNT THE NUMBER OF OVERTRIGGERS
Dim myDATE 'DATE OF LAST ROW
Dim odate 'CURRENT FORMATTED DATE
Dim mySUBJECT As String 'EMAIL SUBJECT LINE TEXT
Dim countRW

'-------------------------------------------------------------
'NEW CODE HERE
myMESSAGE = " "
myTRIGcount = 0
myLASTrw = 8
'FIND LAST ROW
Sheets("Numbers").Select
Do While Cells(myLASTrw, 2).Value ""
myLASTrw = myLASTrw + 1
Loop
myLASTrw = myLASTrw - 1
'LOOP THROUGH COLUMNS
myCOL = 4
Do While myCOL < 19
'GET LAST ROW VALUE
'#################- PROBLEM SECTION-####################
'-THIS IS WHERE I KEEP GETTING THE ERROR, TRYING TO GET THE CELL VALUE
myLASTval = Worksheets("Numbers").Cells(myCOL, myLASTrw).Value
'ALSO TRIED THIS AND GET THE SAME ERROR
'Range(Cells(myCOL, myLASTrw), Cells(myCOL, myLASTrw)).ValueL
'#####################################################
'GET COLUMN TRIGGERS
myTRIGup = Cells(5, myCOL).Value
myTRIGlow = Cells(6, myCOL).Value
'IF LAST ROW VALUE > TRIGGER THEN
If myLASTval > myTRIGup Then
myTRIGcount = myTRIGcount + 1
'GET COLUMN TITLE
myTITLE = Cells(3, myCOL).Value
'GET CELL COMMENTS
cellCOMMENTS = Cells(myLASTrw, myCOL).Comment.Text
'ADD CELL COMMENTS TO EXISTING COMMENTS
myMESSAGE = vbCr & myMESSAGE & vbCr & myTITLE & " went over the " & myTRIGup & " trigger with " & myLASTval & ":" & vbCr & cellCOMMENTS
End If
'IF LAST ROW VALUE < TRIGGER THEN
'GET COLUMN TITLE
'GET CELL COMMENTS
'ADD CELL COMMENTS TO EXISTING COMMENTS
'MOVE TO NEXT COLUMN
cellCOMMENTS = " "
myCOL = myCOL + 1
Loop

'SEND MESSAGE VIA OUTLOOK
myDATE = Cells(2, myLASTrw).Value
odate = Format(myDATE, "mm") & "_" & Format(myDATE, "dd") & "_" & Format(myDATE, "yy")
If myTRIGcount > 0 Then
emailsubj = "JDP INOP OVER TRIGGERS FOR " & odate
Else
emailsubj = "THERE WERE NO JDP INOP OVER TRIGGERS FOR " & odate
End If
Call E_MailOutLook(mySUBJECT, myMESSAGE)
End Sub

Hi all,

I have a workbook that transfers infomation across from another open workbook. This works by a User Form opening which enables me to choose which workbook i copy from.
This all works great, however I am having issues when i try and close down the first workbook. It will only close if all other instances of Excel are closed first.
Not sure if this has something to do with the Userform or not or whether there is something else preventing it from closing.
Here is the code I am using

Code:
Sub GetData()

Const nrData = "Data"
Const shReport = "Report"

Dim rngstr As String

UserForm1.Show
    If WBName = "" Then
       Exit Sub
    Else
        Workbooks(WBName).Names(nrData).RefersToRange.Copy

        rngstr = "A" & LastCellRow(ThisWorkbook.Sheets(shReport)) + 1
        rngstr = rngstr & ":" & MultiLetter(Workbooks(WBName).Names(nrData).RefersToRange.Rows.Count)
        rngstr = rngstr & LastCellRow(ThisWorkbook.Sheets(shReport)) + 1
        
        ThisWorkbook.Sheets(1).Range(rngstr).PasteSpecial _
            Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=True

    End If
    Unload UserForm1
End Sub


Function LastCellRow(ws As Worksheet) As String
  Dim LastRow&

' Error-handling is here in case there is not any
' data in the worksheet

  On Error Resume Next

  With ws

  ' Find the last real row

    LastRow& = .Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row

  End With

  LastCellRow = LastRow

End Function

Function MultiLetter(InputNumber) As String
Dim CumSum As Variant, InputValue As Variant
Dim StringPosition As Integer
Dim i As Integer, Modulus As Integer
Dim TempString As String, PartialValue As Variant
On Error GoTo Err_MultiLetter

  InputValue = CDec(InputNumber)

  If InputValue < 1 Then
    MultiLetter = ""
  Else
    StringPosition = 0
    CumSum = CDec(0)
    TempString = ""
    Do
      PartialValue = Int(CDec((InputValue - CumSum - 1) / (26 ^ StringPosition)))
      ' The code above should be all on 1 line ...

      Modulus = PartialValue - Int(CDec(PartialValue / 26)) * 26
      TempString = Chr(Modulus + 65) & TempString
      StringPosition = StringPosition + 1
      CumSum = CDec(0)
      For i = 1 To StringPosition
        CumSum = CDec((CumSum + 1) * 26)
      Next i
    Loop While InputValue > CumSum
    MultiLetter = TempString
  End If

Exit Function

Err_MultiLetter:
  MsgBox "Error " & Err.Number & ": " & Err.Description

End Function
Any help is appreciated

Cheers

Hello. I have been messing around with sending data to and from access. I have it working, but not correctly. I was wandering if somebody may know why I am getting mixed data when I send it.

The get data code:

Code:
Private Sub cmdGetData_Click()
'run query to find records
    Dim stSQL  As String
    Dim cnt    As ADODB.Connection
    Dim rst    As ADODB.Recordset
    Dim fld    As ADODB.Field
    Dim wsSheet As Worksheet, wbBook As Workbook
    Dim i As Long, j As Long, x As Integer

    'initial SQL to return all records
    stSQL = "SELECT * FROM tblwork"

    On Error GoTo ErrHandle

    Set cnt = New ADODB.Connection
    Set rst = New ADODB.Recordset

    Set wbBook = ThisWorkbook
    Set wsSheet = ThisWorkbook.Worksheets(1)

    With cnt
        .ConnectionString = stCon
        .Open
    End With

    With rst
        .CursorLocation = adUseClient
        .Open stSQL, cnt, adOpenStatic, adLockReadOnly
        .ActiveConnection = Nothing    'Here we disconnect the recordset.
        j = .Fields.Count
        i = .RecordCount
    End With

    With wsSheet
        .UsedRange.Clear
        If i = 0 Then GoTo i_Err
        'Write the fieldnames to the fist row in the worksheet
        For x = 0 To j - 1
            .Cells(1, x + 1).Value = rst.Fields(x).Name
        Next x
        'Dump the data to the worksheet.
        .Cells(2, 1).CopyFromRecordset rst
    End With

    If CBool(rst.State And adStateOpen) = True Then rst.Close
    Set rst = Nothing
    If CBool(cnt.State And adStateOpen) = True Then cnt.Close
    Set cnt = Nothing

ExitHere:
    Exit Sub

ErrHandle:
    Dim cnErrors As ADODB.Errors
    Dim ErrorItem As ADODB.Error
    Dim stError As String

    Set cnErrors = cnt.Errors

    With Err
        stError = stError & vbCrLf & "VBA Error # : " & CStr(.Number)
        stError = stError & vbCrLf & "Generated by : " & .Source
        stError = stError & vbCrLf & "Description : " & .Description
    End With

    For Each ErrorItem In cnErrors
        With ErrorItem
            stError = stError & vbCrLf & "ADO error # : " & CStr(.Number)
            stError = stError & vbCrLf & "Description : " & .Description
            stError = stError & vbCrLf & "Source : " & .Source
            stError = stError & vbCrLf & "SQL State : " & .SqlState
        End With
    Next ErrorItem
    MsgBox stError, vbCritical, "SystemError"
    Resume ExitHere

i_Err:
    MsgBox "There are no records for this Query"
    GoTo ExitHere
End Sub
The send data code:

Code:
Private Sub cmdSendData_Click()

  ' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:test.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "tblwork", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    ' all records in a table
    r = 2 ' the start row in the worksheet
    Do While Len(Range("A" & r).Formula) > 0
    ' repeat until first empty cell in column A
        With rs
            ' add values to each field in the record
            .Fields("ID") = Range("A" & r).Value
            .Fields("WorkID") = Range("B" & r).Value
            .Fields("status") = Range("C" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub
When the data is sent it updates the first row in the table with the last row in the spreedsheet and no other data is changed.

Thanks for your time.

Hi everyone,

I wonder if anybody can help me on this one. I have been working on a macro to copy across rows from a table which satisfy 2 search criteria ('Subsector' and 'Country') to a new workbook. This code loops down each row until it finds a match for the 'Subsector' criteria, wherupon it checks each cell of this row to find a 'Country' match. If a match is found, I want it to copy this row (or better still, the row of the CurrentRegion) to a new workbook. Here is what I have come up with so far:

Option Explicit

Private Sub CommandButton1_Click()
Dim wbo As Workbook 'Active workbook i.e. Credentials spreadsheet
Dim CredSearch As Workbook 'New workbook i.e. CredSearch workbook
Dim SearchResults As Worksheet
Dim subsector As String 'Subsector criteria
Dim country As String 'Country criteria
Dim i As Integer 'Row counter on Credentials worksheet
Dim j As Integer 'Column counter on Credentials worksheet
Dim c As Integer 'row counter on CredSearch worksheet
Dim cs As Integer 'Column vector for Client Subsector column
Dim ds As Integer 'Column vector for Deal Subsector

'Initialise wbo as current workbook
Set wbo = ActiveWorkbook

'Initialise search criteria
subsector = Cells(5, 4).Value
country = Cells(6, 4).Value

'Locate Client and Deal Subsector columns on 2007 worksheet
With wbo.Worksheets("2007")
For j = 1 To .Range("A1").CurrentRegion.Columns.Count
If .Cells(1, j).Value = "Client Subsector (New)" Then
cs = j
ElseIf .Cells(1, j).Value = "Deal Subsector (New)" Then
ds = j
End If
Next j
End With

'Initialise CredSearch as new workbook
Set CredSearch = Workbooks.Add(xlWorksheet)
CredSearch.Sheets(1).Name = "Results"
CredSearch.Sheets("Results").Rows(1).Value = wbo.Worksheets("2007").Rows(1).Value

'Locate deals satisfying Subsector and Country criteria
c = 1

With wbo.Worksheets("2007")
For i = 2 To .Range("A1").CurrentRegion.Rows.Count
If .Cells(i, cs).Value = subsector Or .Cells(i, ds).Value = subsector Then
For j = 1 To .Range("A1").CurrentRegion.Columns.Count
If InStr(.Cells(i, j), country) > 0 Then
c = c + 1
Exit For
End If
Next j
**'**
End If

Next i
End With

MsgBox "Found" & Str(c - 1) & " deals matching subsector and country criteria"

End Sub

As a relative newbie to Excel VBA, any assistance you could provide would be greatly appreciated.

Many thanks

Hi All:

Two things I am looking for...

1) I was wondering what piece of code I can use that will automatically DELETE the first 2 rows of my spreadsheet?

2) Is there a piece of code that will wipe out (or disable) all code in a spreadsheet prior to it being mailed?

I am using the code below to e-mail 1 sheet to someone and I want to rip the code out prior to sending it or at least disable it so that when the spreadsheet is opened at the other end there is no prompt to Enable or Disable macros. For the record the code I need removed is on Sheet 1 (titled: Invoice Request). Hope this makes sense... Here is the code I am using to e-mail the sheet (modified Ron DeBruin code):

Code:
 
Sub Mail_Sheet_To_NTRMB()
'Sub Mail_ActiveSheet()
'Working in 2000-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
    
    'Remove Filter
    Application.Run "UnhideBlankRows"
 
    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
 
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With
 
    '    'Change all cells in the worksheet to values if you want
    ActiveSheet.Unprotect "cheryl"
        With Destwb.Sheets(1).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
        
        'Delete BLANK Rows before e-mailing sheet to NTRMB
        Application.Run "Delete_Blank_Rows"
        
        'REMOVE Buttons
    ActiveSheet.Shapes("EmailForm").Select
    Selection.Cut
    
    ActiveSheet.Shapes("AddMoreData").Select
    Selection.Cut
    
    'ActiveSheet.Shapes("EmailForm").Select
    'Selection.Cut
 
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & ""
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "mark@ontario.ca"
            .CC = ""
            .BCC = ""
            .Subject = "Bulk ARIR Request form attached for processing"
            .Body = "To Whom It May Concern:  Please find attached a Bulk ARIR form for Review and Processing."
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    Set OutMail = Nothing
    Set OutApp = Nothing
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Any Suggestions???

THANKS,
Mark

Hi

I'm having trouble performing a find/replace in Word 2003, from VBA in Excel. I'm essentially doing a complicated mail merge, where I open up a SourceDoc, copy that into TempDoc then do find and replace on certain strings (such as Contact) then paste that into MergeDoc. The copy and paste from SourceDoc to TempDoc works fine, however I keep getting "Method 'Execute' of object 'Find' failed."

I have tried setting all the find options first with .text and .replacement etc, but Excel just crashes in this case. My code is below (just the bit up until the find method fails.)

Code:
    Dim WdApp As Word.Application
    Dim MergeDoc As Word.Document, SourceDoc As Word.Document, TempDoc As Word.Document
    
    Set WdApp = New Word.Application
    Set SourceDoc = WdApp.Documents.Open("C:SourceDoc.doc", ReadOnly:=True, AddToRecentFiles:=False)
    Set MergeDoc = WdApp.Documents.Add
    Set TempDoc = WdApp.Documents.Add
           
        WdApp.Visible = True
        SourceDoc.Content.Copy
        TempDoc.Content.Paste
        TempDoc.Content.Find.Execute "Contact", ReplaceWith:="blah", Replace:=wdReplaceAll
If anyone could shed any light on why the find is failing that would be great, I can't see what I'm doing wrong and have tried a load of different things but can't seem to get it right.

Thanks
Andy

Hi,

I am currently trying to make my first VBA enhanced spreadsheet. It is basically a spreadsheet that uses 2 lookup tables to find values for use in the building construction industry.

My question is this:

I want to have multiple sheets with information on them and a front page that gives options for each sheet (the options are in the form of buttons that the user simply clicks to do as they wish). One of these options will be to print that specific sheet (each sheet has a row of buttons). This is where I seem to run into problems. Without having a macro for each specific sheet how can I use the button to print out the sheet I want.

The current print macro code is as follows:

Sub print_to_pdf( shtname As String)
Sheets(shtname).Select
Application.ActivePrinter = "CutePDF Writer on CPW2:"
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Sheets("Options").Select
End Sub

From my limited knowledge it appears that you cant pass information to a macro from a button press (i.e. print_to_pdf("Sheet1")) you can only pass a 'flat' macro name (i.e. print_to_pdf).

Is there anyway that I can get the button to A. Pass information to a macro Or B. Have the button return its position when it is toggled (if I knew the positon of which button was pressed then I can work back from that to find out which sheet is needed to be printed).

Any other ways round this problem would be greatly appreciated.

I am using windows Xp and excel 2003

Thanks in advance,
Matt.

Hello.

I'm a beginner in VBA programming.
During studying 'find' method, i encountered a problem.

Microsoft Excel - test.xls___Running: xl2000 : OS = Windows XP (F)ile (E)dit (V)iew (I)nsert (O)ptions (T)ools (D)ata (W)indow (H)elp (A)boutA7=

ABCD1Where is he!Where is he.2Where is he?Where is he!3Where is he.Where is he going to go?4Where is he going to go?Where is he?Sheet1
[HtmlMaker 2.42] To see the formula in the cells just click on the cells hyperlink or click the Name box
PLEASE DO NOT QUOTE THIS TABLE IMAGE ON SAME PAGE! OTHEWISE, ERROR OF JavaScript OCCUR.

Sub Test()
Dim rng As Range
Dim Addr As String
With Range("d1:d4")
Set rng = .Find(Range("a2"), LookIn:=xlValues) 'Where is he?
If Not rng Is Nothing Then
Addr = rng.Address
Do
MsgBox Addr & " (" & Range(Addr) & ")" 'Show result
Loop While Not rng Is Nothing And rng.Address Addr
End If
End With
End Sub
I think the result should be "$D$4(Where is he?)"
but, in this case, result message shows "$D$2(Where is he!)"
it looks simple. but i don't know what's wrong.
I would appreciate it if you teach me why i've got this result.

Hi All,
I'm a newbie with VBA although I have some experience with other languages (such as Delphi). I am trying to automate retrieving the results of multiple SQL queries into an excel sheet. I have the following code:

Code:
Sub LFR_Query()
Dim RunDate As String
Dim sSQL As String
Dim WriteRow As Integer

RunDate = Range("Data!B2").Value

'--------------------------- Query 1 ---------------------------
sSQL = "SELECT * FROM db_owner.LFR_Main_Data WHERE Run='" & RunDate & "';"

'Find the last row containing data and add 2
WriteRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
    With ActiveSheet.QueryTables.Add(Connection:=Array( _
        "ODBC;DSN=LFR_DB;DATABASE=LFR;Trusted_Connection=Yes"), Destination:=Range("A" & WriteRow))
        .CommandText = Array(sSQL)
        .Name = "Run Query from LFR_DB"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery = False
    End With
'------------------------- End Query 1 -------------------------
 
'--------------------------- Query 2 ---------------------------
sSQL = "SELECT Project, Type, Sum(R1) AS M1, Sum(R2) AS M2, Sum(R3) AS M3, Sum(R4) AS M4, Sum(R5) AS M5, Sum(R6) AS M6,
Sum(R7) AS M7, Sum(R8) AS M8, Sum(R9) AS M9, Sum(R10) AS M10, Sum(R11) AS M11, Sum(R12) AS M12, " _
       & "Sum(R13) AS M13, Sum(R14) AS M14, Sum(R15) AS M15, Sum(R16) AS M16, Sum(R17) AS M17, Sum(R18) AS M18, Sum(R19) AS
M19, Sum(R20) AS M20, Sum(R21) AS M21, Sum(R22) AS M22, Sum(R23) AS M23, Sum(R24) AS M24 " _
       & "FROM db_owner.LFR_Main_Data GROUP BY Project, Type ORDER BY LFR_Data.Type WHERE Run='" & RunDate & "';"

'Find the last row containing data and add 2
WriteRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
    
    With ActiveSheet.QueryTables.Add(Connection:=Array( _
        "ODBC;DSN=LFR_DB;DATABASE=LFR;Trusted_Connection=Yes"), Destination:=Range("A" & WriteRow))
        .CommandText = Array(sSQL)
        .Name = "Projects total load"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery = False
    End With
'------------------------- End Query 2 -------------------------
End Sub
Query 1 works just fine on its own. When I added query 2 which is basically a copy of query 1 with different SQL the code breaks with an error 13 Type mismatch... Any ideas?

Thanks in Advance,
Avi

The code below allows me to enter data into a form by double clicking on a cell in column A. When I enter my data into the form, I click “new entry”, the data is entered into the last unfilled row. What I like to accomplish in addition to the above code is take existing data from my worksheet and have it auto-fill the form so I can make changes to that existing data and than put the corrected data back into the same row the data came from.

Double-Click Code for Cells in Column A:

Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Not (Nothing Is Application.Intersect(Target, Range("A:A"))) Then
Cancel = True
frmLogbook.Show
End If
End Sub
 
 
"New Entry" button Code:
 
Private Sub CommandButton1_Click()
Private Sub cmdAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Logbook")
 
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
 
'check for a part number
If Trim(Me.txtDATE.Value) = "" Then
Me.txtDATE.SetFocus
MsgBox "Please Make an Entry"
Exit Sub
End If
 
'copy the data to the database
ws.Cells(iRow, 1).Value = Me.txtDATE.Value
ws.Cells(iRow, 2).Value = Me.txtTYPE.Value
ws.Cells(iRow, 3).Value = Me.txtIDENT.Value
ws.Cells(iRow, 4).Value = Me.txtROUTE.Value
ws.Cells(iRow, 5).Value = Me.txtTOTAL.Value
ws.Cells(iRow, 6).Value = Me.txtSEL.Value
ws.Cells(iRow, 7).Value = Me.txtSES.Value
ws.Cells(iRow, 8).Value = Me.txtMEL.Value
ws.Cells(iRow, 9).Value = Me.txtOPT1.Value
ws.Cells(iRow, 10).Value = Me.txtOPT2.Value
ws.Cells(iRow, 11).Value = Me.txtOPT3.Value
ws.Cells(iRow, 12).Value = Me.txtOPT4.Value
ws.Cells(iRow, 13).Value = Me.txtOPT5.Value
ws.Cells(iRow, 24).Value = Me.txtPIC.Value
ws.Cells(iRow, 25).Value = Me.txtSIC.Value
ws.Cells(iRow, 27).Value = Me.txtCFI.Value
ws.Cells(iRow, 23).Value = Me.txtSOLO.Value
ws.Cells(iRow, 26).Value = Me.txtDUAL.Value
ws.Cells(iRow, 22).Value = Me.txtXCTRY.Value
ws.Cells(iRow, 21).Value = Me.txtFLTSIM.Value
ws.Cells(iRow, 17).Value = Me.txtIMC.Value
ws.Cells(iRow, 18).Value = Me.txtSIM.Value
ws.Cells(iRow, 16).Value = Me.txtNIGHT.Value
ws.Cells(iRow, 19).Value = Me.txtAPPCH.Value
ws.Cells(iRow, 20).Value = Me.APPCHTYPE.Value
ws.Cells(iRow, 14).Value = Me.txtDAY.Value
ws.Cells(iRow, 15).Value = Me.txtNIGHTLDG.Value
ws.Cells(iRow, 28).Value = Me.txtREMARKS.Value
 
'clear the data
Me.txtDATE.Value = ""
Me.txtTYPE.Value = ""
Me.txtIDENT.Value = ""
Me.txtROUTE.Value = ""
Me.txtTOTAL.Value = ""
Me.txtSEL.Value = ""
Me.txtSES.Value = ""
Me.txtMEL.Value = ""
Me.txtOPT1.Value = ""
Me.txtOPT2.Value = ""
Me.txtOPT3.Value = ""
Me.txtOPT4.Value = ""
Me.txtOPT5.Value = ""
Me.txtPIC.Value = ""
Me.txtSIC.Value = ""
Me.txtCFI.Value = ""
Me.txtSOLO.Value = ""
Me.txtDUAL.Value = ""
Me.txtXCTRY.Value = ""
Me.txtFLTSIM.Value = ""
Me.txtSIM.Value = ""
Me.txtNIGHT.Value = ""
Me.txtAPPCH.Value = ""
Me.APPCHTYPE.Value = ""
Me.txtDAY.Value = ""
Me.txtNIGHTLDG.Value = ""
Me.txtREMARKS.Value = ""
Me.txtDATE.SetFocus
 
Unload Me
End Sub

What is currently showing in my VBA project (ATL-F11) is frmLogbook and Module 1. Module 1 has the following code below…

Code:
Sub Rectangle3_Click()
ShowForm.Show False
End Sub
'------------------------------------------------------------------------------------------------------------
Sub ShowForm()
With frmLogbook.APPCHTYPE
.RowSource = ""
.AddItem "ILS"
.AddItem "LOC"
.AddItem "VOR"
.AddItem "NDB"
.AddItem "LDA"
.AddItem "BC-LOC"
.AddItem "RNAV"
.AddItem "GPS"
.AddItem "MLS"
End With
frmLogbook.Show
End Sub
I was collaborating with a member who was helping me with this problem, but I was not successful in implementing the code. The code below is supposed to accomplish what I’m trying to achieve, but it does not take the existing data and autofill the form. I was wondering if anyone else could help me with this.

Code:
Option Explicit
Dim myCells As Range
 
Private Sub UserForm_Initialize()
With ActiveCell
If .Value = vbNullString Then
With .Parent
Set myCells = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
Else
Set myCells = ActiveCell.EntireRow.Range("A1")
End If
Set myCells = myCells.Resize(1, 28)
End With
Call FromSheetToUserform
Me.txtTYPE.SetFocus
End Sub
 
Sub FromSheetToUserform()
Dim myData As Variant
 
myData = Application.Transpose(Application.Transpose(myCells.Value))
 
With Me
.txtDATE.Text = CStr(myData(1))
.txtTYPE.Text = CStr(myData(2))
Rem code
.txtREMARKS.Text = CStr(myData(28))
End With
End Sub
 
Private Sub CommandButton1_Click()
With Me
If .txtDATE.Text = vbNullString Then
MsgBox "Please enter a DATE"
.txtDATE.SetFocus
Else
myCells.Range("A1").Select
Call FromUFormToSheet
Call clearTextBoxes: Rem not needed if form is to be unloaded
Unload Me
End If
End With
End Sub
 
Sub FromUFormToSheet()
Dim myData() As String
ReDim myData(1 To myCells.Cells.Count)
 
With Me
myData(1) = .txtDATE.Text
myData(2) = .txtTYPE.Text
Rem code
myData(28) = .txtREMARKS
End With
 
myCells.Value = myData
End Sub
 
Sub clearTextBoxes()
Dim xControl As Object
For Each xControl In Me.Controls
If TypeName(xControl) = "TextBox" Then
xControl.Text = vbNullString
End If
Next xControl
End Sub
I hoping someone can help me solve this. I really, really, really, would like to have this feature in my project

Have a small project where management, using third party software storing the data on SQLServ 2005, were storing files on a shared drive and recording path/filename in the database. I have an Excel VBA workbook that queries the Server for a list of filenames (at present 55+, soon to grow over 300), opens them all in turn, parses, and copies the data into one sheet for presentation to management. This is all working quite nicely.

Now management are (for security reasons) forcing the software to store the files internally for version control, and thus I can't read from the source documents anymore. The files are now stored in a Table as binary data. I can guarantee that all files stored are .xls, but does anyone know a way in either T-SQL or Excel VBA that I can extract these and either open, them or at worst save temporary copies?

I can generate the correct queries, picking up filesize, origninal path and name, but the code breaks when it attempts to display the 'binary' data. Ideally I'd love a ReadBinaryDataAndOpenAsWorkbook(MySqlQuery String) Method but any suggestions would certainly help.

Brad

(Original Read and Display Code Below (Edited for Security))

Additional Referencing;
Microsoft ActiveX Data Objects 2.8 Library
Microsoft ActiveX Data Objects Recordset 2.8 Library

Code:
Public Sub DataExtract()
  ' Create a connection object.
  Dim cnPubs As ADODB.Connection
  Set cnPubs = New ADODB.Connection
  strConn = "PROVIDER=;Server=;Database=;INTEGRATED SECURITY=;"
  
  'Now open the connection.
  cnPubs.Open strConn
  
  ' Create a recordset object.
  Dim rsPubs As ADODB.Recordset
  Set rsPubs = New ADODB.Recordset

  With rsPubs
    ' Assign the Connection object.
    .ActiveConnection = cnPubs
    ' Extract the required records.
    .Open "SELECT path, filename FROM..."
    ' Copy the records into cell A1 on Sheet1.
    Sheet2.UsedRange.Clear
    Sheet2.Range("A1").CopyFromRecordset rsPubs
        
    .Close
  End With

  cnPubs.Close
  Set rsPubs = Nothing
  Set cnPubs = Nothing

End Sub

Code:
Sub Files2File()
  '
  Dim varFilenames As Variant
  Dim strActiveBook As String
  Dim strSourceDataFile As String
  Dim strTest As String
  Dim wSht As Worksheet
  Dim allwShts As Sheets
  Dim counter As Integer
  Dim lRows As Long
  Dim newSheet As Integer
  
    Workbooks.Add
    strActiveBook = ActiveWorkbook.Name
    
    ' Create array of filenames; the True is for multi-select
    On Error GoTo exitsub
    varFilenames = Application.GetOpenFilename(, , , , True)

    counter = 1

    ' ubound determines how many items in the array
    On Error GoTo quit
    Sheets.Add
    
    Application.ScreenUpdating = False
    While counter

I would like to put a number on the end of the filename like revision 1, revision 2, revision 3....etc. like could the code find the latest revision and add 1.

Also this code sorta works when the filename doesn't exist except excel flips out and forces me to close. i can recover my recently renamed file. there's no problem if the file already exists.

thanks

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim myDir As String, FileToSave As String
myDir = "C:Documents and SettingsbrennerDesktop"
FileToSave = "Biz " & Range("j3").Value & " (" & Format(Date, "mmm dd yyyy") & ") " & Range("k5").Value

If Dir(myDir & FileToSave & ".xls") "" Then
ActiveWorkbook.SaveAs (myDir & FileToSave & "revised.xls")
Else
ActiveWorkbook.SaveAs (myDir & FileToSave & ".xls")
End If

End Sub

As part of a little Excel macro, the sub below gets called to produce an e-mail, where I hope to distribute some information from a list in Excel:

Code:
Private Sub CreateEmail(sContact As String, wksTemp As Worksheet, _
    olApp As Outlook.Application)
    
    Dim olMail As Outlook.MailItem
    Dim sFirstName As String, sBody As String
    
    sFirstName = Left(sContact, InStr(sContact, " ") - 1)
    sBody = "Hi " & sFirstName & "," & vbNewLine & vbNewLine & _
        "Could you confirm the retirements listed below?" & vbNewLine & vbNewLine
    
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .Display
        .Recipients.Add sContact
        .Subject = "Retirement confirmation request"
        .Body = sBody
        .Attachments.Add
    End With
End Sub
I'd like to add to this by having the code paste a portion of an Excel list, which I'll call rList. I know I could get around this using a statement like Code:
 but I'd rather add to the existing body of the e-mail and have the macro paste rList at the end, as opposed to adding an
attachment... Does anyone have any ideas?  I thought it would be simple when I started, but find myself at a loss as to how
to actually execute.

Hello Excel Gurus!

I am wondering if there is anything I can do to set a variable to the name of the first sheet that does not contain the string "report" or the character "~" and assign it to a variable "GoodSheet1" in VBA. Then find the next sheet that fits the criteria and assign that to another variable "GoodSheet2". And continue on through all the sheets.

I am thinking that it involves a loop, but I'm not sure how to look for a sheet name that does not contain certain text strings, much less how to choose the first, second, third, etc of that sheet.

Any guidance would be fantastic, even if it just gets me started!

Hi again.

here's the deal:

I have a file with a main userform that activates when the workbook is opened. On that userform, we have 2 options: "Creating an Entry" and "Replacing an "entry". I have done all the VBA code for the "creating an Entry" and it works perfectly (thanks Lewiy again!!!) but now I need to do some stuff that I have never done on VBA before:

Basically what I want it to do:

A new userform opens with several fields:
"reference number" input text-box (name= RefReplaceNew)
"title" input text-box (name= TitleReplaceNew)
"Category" input text-box (name= CategoryReplaceNew)

and then underneath another "reference number" (name= RefReplaceOld ) input text-box but this time for the data I want to replace in the database.

The problems start here:
I need Excel to search and find (hopefully) the second "reference number" in the column A (more than 3.000 entries) and then save the info from column A,B and C of that line (a simple 3 line variable with x = something; y = something and z = something should be enough to do that)
Then having saved that information, input in column A the information from RefReplaceNew), B the info from TitleReplaceNew) and in C info from CategoryReplaceNew.

then I need it to go to the first empty cell in column A and input the saved info from x in B the saved info y and in C the info in z.

Any ideas?

I'm trying to create a variable which is pulled from a cell in a worksheet, currently it has the fullname of the file, so Repbook.xls

With a sub I'm trying to remove the .xls component of this?

I'd started off in the direction of;

Code:
Dim RepBookToUpdate As Variant
Dim RepBook As Variant
RepBook = Range("C49").Value
RepBookToUpdate = ???
Is there a quick an easy way for this?

edit: from just the Excel side of it

Code:
gives me just the component I need - can I grab that via VBA easily?

Thank you for your time.

Hi

I am using excel 97 sr-2. I am trying to create some user functions
and would like to name them in alpha numerical ie BB1654 or BA16965
When I create them the function does not work. If I rename the function
using any name ommitting numbers it works ok

ex

'function to find how many conical springs are reqd on
'part no BA16965

Function conical(part As String, qty As Integer) As Long
Dim multiple As Integer

Select Case part
Case Is = 13200
multiple = 2
Case Is = 13201
multiple = 2
Case Is = 84
multiple = 1
Case Is = B26975
multiple = 1
End Select

conical = multiple * qty

End Function

I wanted to call the function BA16965 as that was the part it was checking for, but because it did not work I changed it to conical.

I am not aware of any naming restriction.

Regards

Phill

Hi guys

Im having a huge problem with my VBA code. Im not a huge and almighty wizzard on Excel, so therefore I turn to greater knowledge

This problem only occurs in Excel 2007.

Im copying a whole HTML page, with links.
Paste it into Excel on a sheet.

In excel 2003 this is done by the second, but now, the time for it to paste the site in the worksheet takes me like ages.

Ive been trying paste special + other things mentioned in other threads,but nothing has resolved my problem.

Anyone with a solution to my problem?

Millions thanks.

Private Sub Workbook_Open()

Application.ScreenUpdating = False

Sheets("XXX").Visible = True

Set myData = New DataObject

Dim myIE As Object
Set myIE = New InternetExplorer

Dim myURL As String
myURL = "http://www.blablabla.com"

myIE.navigate myURL

Do While myIE.Busy Or myIE.readyState READYSTATE_COMPLETE
DoEvents
Loop

myData.SetText myIE.Document.body.innerHTML
myData.PutInClipboard

myIE.Quit

Windows("XXX.xlsm").Activate
Sheets("XXX").Select
Range("A1").Select

This part gets on my nerves...

ActiveSheet.Paste
Application.CutCopyMode = False

-----------------------

Columns("A:X").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste

Range("A1").Select
Sheets("XXX").Select
Range("A16:P25").Select
ActiveWorkbook.Worksheets("XXX").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("XXX").Sort.SortFields.Add Key:=Range("P16:P25"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("XXX").Sort
.SetRange Range("A15:P25")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2:P11").Select
ActiveWorkbook.Worksheets("XXX").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("XXX").Sort.SortFields.Add Key:=Range("P3:P11"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("XXX").Sort
.SetRange Range("A2:P11")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select

Application.CutCopyMode = False

Sheets("blabla").Visible = False

Application.ScreenUpdating = True

End Sub


No luck finding an answer? You could always try Google.