Access VBA: Extract number after a specific word from a full length string

If we need to extract a number after a specific word from a full length string, as shown in below example, we can use below function

Private Sub Command1_Click() 
Dim db As DAO.Database
Set db = CurrentDb
Dim x As String
Dim y As String
x = "SpecificWord_1234 56"
y = GetNumber(Mid(x, InStr(x, "SpecificWord_") + 13))
'MsgBox GetNumber(x) 
MsgBox y 
End Sub

' Note 'SpecificWord_' has 13 chars.'Hence mentioned 13.'It as to be length of the SpecificWord that you are specifying

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

Function GetNumber(varS As Variant) As Variant 

Dim x As Integer
GetNumber = Null 

If varS & "" Like "*#*" Then
For x = 1 To Len(varS)
If IsNumeric(Mid(varS, x, 1)) Then
GetNumber = Val(Mid(Replace(varS, " ", "|"), x))

' GetNumber = Replace(varS, " ", "|") -- commented - for step by step test if needed
' GetNumber = Mid(GetNumber, x) -- commented - for step by step test if needed
' GetNumber = Val(GetNumber) -- commented - for step by step test if needed

Exit For

End If
Next

End If
End Function

Example: If we need to extract first occurrence number available after the word DoorNumber, from below full string
SomeWord_123_SomeOtherWords_DoorNumber_12345_OtherWord_456

In this case we have to modify the function as shown below

y = GetNumber(Mid(x, InStr(x, "DoorNumber_") + 11)) 'Because length of (DoorNumber_) is 11

SQL Server: Word count in a string

I needed count of words available in each record of a specific column. So that I could order on the record string which has highest words. Below function will does the task. This function will not exclude special chars or numbers.

CREATE FUNCTION [dbo].[WordCount] ( @InputString VARCHAR(4000) )
RETURNS INT
AS
BEGIN

DECLARE @Index          INT
DECLARE @Char           CHAR(1)
DECLARE @PrevChar       CHAR(1)
DECLARE @WordCount      INT

SET @Index = 1
SET @WordCount = 0

WHILE @Index <= LEN(@InputString)
BEGIN
    SET @Char     = SUBSTRING(@InputString, @Index, 1)
    SET @PrevChar = CASE WHEN @Index = 1 THEN ' '
                         ELSE SUBSTRING(@InputString, @Index - 1, 1)
                    END

    IF @PrevChar = ' ' AND @Char != ' '
        SET @WordCount = @WordCount + 1

    SET @Index = @Index + 1
END

RETURN @WordCount

END
GO

If we need to exclude numbers and non printable chars, then below function can be used

CREATE function fn_how_many_words(
    @source varchar(max) )
    returns int
as
begin
    declare @start int

    --  break any multiple spaces down
    while 1=1
    begin
        set @start = len( replace( @source, '  ', ' ' ) )
        set @source = replace( @source, '  ', ' ' )
        if @start = len( replace( @source, '  ', ' ' ) )
            break

    end
    --  get rid of any non letters and numbers
    set @start = 1
    while @start <= 255
    begin
        if @start not between ascii( 'a' ) and ascii( 'z' )
           and @start not between ascii( 'A' ) and ascii( 'Z' )
           and @start not between ascii( '0' ) and ascii( '9' )
           and @start <> ascii( ' ' )

           set @source = replace( @source, char( @start ), '' )
         set @start = @start + 1
    end

    return( len( @source ) - len( replace( @source, ' ', '' ) ) + 1 )
end

MS Access: Export excel from MS Access and perform Formatting

I needed to export data from access and do some formatting at the same time. So this code helped me to perform this.

Private Sub Command0_Click()

Dim db As DAO.Database
Set db = CurrentDb()

' Drop table if exists
If ifTableExists("ACCESS_TABLE") Then db.Execute "DROP Table ACCESS_TABLE"

' Import data from SQL table
DoCmd.TransferDatabase acTable, "ODBC Database", _
"ODBC;Driver={SQL Server};Server=192.168.0.0;UID=username;PWD=password;LANGUAGE=us_english;" _
& "DATABASE=DatabaseName", acTable, "SQL_TABLE", "ACCESS_TABLE"

'Excel Export and Formatting

Dim n1 As String
Dim xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim xlsheet1 As Excel.Worksheet

n1 = CurrentProject.Path + "\DestinationExcelName.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ACCESS_TABLE", n1, True

On Error Resume Next
Set xl = GetObject(n1, "Excel.Application")
On Error GoTo 0
If xl Is Nothing Then
  Set xl = CreateObject("Excel.Application")
End If

Set XlBook = GetObject(n1)

'Make sure excel is visible on the screen
xl.Visible = True
XlBook.Windows(1).Visible = True

'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
XlBook.Activate
AppActivate xl.Caption

With xlsheet1
    .range("A1:C1").Interior.Color = RGB(192, 192, 192) ' Grey "Fill color"
    .range("D1:F1").Interior.Color = RGB(255, 255, 0) ' Yellow "Fill color"
    .range("G1:I1").Interior.Color = RGB(255, 204, 153) ' Orange "Fill color"

    .range("A1:C1").Font.Color = RGB(255, 255, 255) ' White "Font color"
    .rows("1:1").Font.Bold = True  ' "Font weight - Bold"

End With

XlBook.Save

MsgBox "DestinationExcelName.xlsx file exported. Please check"

End Sub


Public Function ifTableExists(tablename As String) As Boolean

ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tablename & "'") = 1 Then
ifTableExists = True
Else
ifTableExists = False
End If

End Function

MS Excel: Combine all workbooks available under a single folder in to one

We had a requirement of combining all workbooks (Not work sheets) which are available in a folder, into one worksheet.
Condition: Combine only with Sheetname "Updated" from all available Excel workbooks.

As I am not a very good VBA programmer, I could do this in two steps.

Step1: 

• Copy below script into a new excel module where all workbook data has to combine
• Execute script to loop through all excels, select and copy sheetname having "Updated" to current workbook
• Worksheets will be copied in different worksheets as Updated1, Updated2, Updated3 etc.. under current workbook

Sub GetSheets()
Path = "D:\AllWorkbooksFolder\"
Filename = Dir(Path & "*.xls")
  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
'    For Each Sheet In ActiveWorkbook.Sheets
        Sheets("Updated").Select
            Sheets("Updated").Copy After:=ThisWorkbook.Sheets(1)
'    Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
  Loop
End Sub

Step2: 

Combine all excel worksheets into one by executing another VBA script as below.

Sub CombineSheets()
   Dim ws As Worksheet, wsCombine As Worksheet
   Dim rg As Range
   Dim RowCombine As Integer

   Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
   wsCombine.Name = "Combine"

   RowCombine = 1
   For Each ws In ThisWorkbook.Worksheets
      If ws.Index <> 1 Then
         Set rg = ws.Cells(1, 1).CurrentRegion
         rg.Copy wsCombine.Cells(RowCombine, 2)
         wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)).NumberFormat = "@"
         wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name
         RowCombine = RowCombine + rg.Rows.Count
      End If
   Next
   wsCombine.Cells(1, 1).EntireColumn.AutoFit
   Set rg = Nothing
   Set wsCombine = Nothing
End Sub

MS Access: Drop all link tables

Below is the function to drop all link tables available in access file. We cal call where ever it is required.

Public Function DropLinkTables()
   'delete any tables where connection property has ODBC in it
   Dim tdf As DAO.TableDef
StartAgain:
 For Each tdf In CurrentDb.TableDefs
    If InStr(1, tdf.Connect, "ODBC") Then
       DoCmd.DeleteObject acTable, tdf.Name
       GoTo StartAgain
    End If
 Next tdf
 Set tdf = Nothing
End Function

SQL Server: Create tablename with dates assigned dynamically between specified dates

I needed a script to create tables with dates assigned. For example if needed a table to be created like
abc_01Jun2017
abc_02_Jun2017
abc_03_Jun2017
abc_04_Jun2017
So I will have to pass 4 parameters i.e. (a) SchemaName (b) TableName (c) StartDate (d) EndDate
In the above case the parameters would be (a) SchemaName = 'myschema' (b) TableName  = 'abc' (c) StartDate= '06/01/2017' (d) EndDate = '06/04/2017'

So I have created a script to perform this

USE [MyDatabase]
GO

--select CONVERT(VARCHAR(11),GETDATE(),106)
--select Replace((select CONVERT(VARCHAR(11),GETDATE(),106)),' ','')

Declare @str varchar(5000)
Declare @TableName varchar(100)
Declare @SchemaName varchar(100)
Declare @StartDate Date
Declare @EndDate Date

SET @SchemaName = 'myschema'
SET @TableName = 'abc'
SET @StartDate = '06/01/2017'
SET @EndDate = '06/04/2017'

Declare @NoOfDays int
SET @NoOfDays = (SELECT Datediff(day,@StartDate,@EndDate)) + 1

Declare @StartDatestr varchar(20)
Declare @EndDatestr  varchar(20)

Declare @Counter int
SET @Counter = 1

While (@Counter<=@NoOfDays)

BEGIN

SET @StartDatestr = Replace((select CONVERT(VARCHAR(11),@StartDate,106)),' ','')

Declare @sql1 As varchar(4000)
set @sql1 = 'IF EXISTS (SELECT * FROM sys.objects WHERE object_id = OBJECT_ID(N'+''''+@SchemaName+'.'+@TableName+'_'+@StartDatestr+''') AND TYPE IN (N'+'''U'''+')) BEGIN
DROP TABLE ' + Quotename(@SchemaName+'.'+@TableName+'_'+@StartDatestr) + ' END'

Exec (@sql1)

SET @str = 'create Table '+@SchemaName+'.'+@TableName+'_'+@StartDatestr +'
(
ID int -- We should specify required column names
)'


Exec (@str)

SET @Counter = @Counter + 1
SET @StartDate = DATEADD(day,1,@StartDate)

END



 

MS Access: Export Table or Query data from access in to existing excel sheet

I needed to export data from access table to an existing excel file and on an existing sheet. For this I found a very good solution through this website.

Public Function SendTQ2XLWbSheet(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strFilePath is the name and path of the file you want to send this data into.

Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Dim strPath As String
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
On Error GoTo err_handler

strPath = strFilePath

Set rst = CurrentDb.OpenRecordset(strTQName)

Set ApXL = CreateObject("Excel.Application")

Set xlWBk = ApXL.Workbooks.Open(strPath)

ApXL.Visible = True

Set xlWSh = xlWBk.Worksheets(strSheetName)

xlWsh.Activate

xlWSh.Range("A1").Select

For Each fld In rst.Fields
ApXL.ActiveCell = fld.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next

rst.MoveFirst

xlWSh.Range("A2").CopyFromRecordset rst

xlWSh.Range("1:1").Select
' This is included to show some of what you can do about formatting. You can comment out or delete
' any of this that you don't want to use in your own export.
With ApXL.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With

ApXL.Selection.Font.Bold = True

With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With

' selects all of the cells
ApXL.ActiveSheet.Cells.Select

' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit

' selects the first cell to unselect all cells
xlWSh.Range("A1").Select

rst.Close

Set rst = Nothing

Exit_SendTQ2XLWbSheet:
Exit Function

err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_SendTQ2XLWbSheet
End Function

Usage

Call SendTQ2XLWbSheet("MyQueryNameHere", "SheetNameHere", "PathAndFileNameHere")