SQLjuMBLe: December 2021

Post-19 Delete Consecutive row in Excel Macros:

Sub deleteeveryotherrow()
For x = 1 To 100 Step 1
Rows(x & ":" & x).Select
    Selection.Delete Shift:=xlUp
    Next x
End Sub

Post-18 Merge different excel workbooks into a single workbook into different sheets:

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True) 
    If (vbBoolean <> VarType(fnameList)) Then 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Set wbkCurBook = ActiveWorkbook
            For Each fnameCurFile In fnameList
            countFiles = countFiles + 1
            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
            For Each wksCurSheet In wbkSrcBook.Sheets
 countSheets = countSheets + 1
 wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
 Next
   wbkSrcBook.Close SaveChanges:=False
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Post-17 Combine all Sheets into one Master Sheet in Excel Macros:

Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()
'Procedure to Consolidate all sheets in a workbook
On Error GoTo IfError

'1. Variables declaration
Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range

'2. Disable Screen Updating - stop screen flickering
'   And Disable Events to avoid inturupted dialogs / popups
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'3. Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True

'4. Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Consolidate_Data"
End With

'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       '5.1: Find the last row on the 'Consolidate_Data' sheet
       DstRow = fn_LastRow(DstSht) + 1          
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("A1:" & EnRange)
'5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
        GoTo IfError
        End If            
'5.4: Copy data to the 'consolidated_data' WorkSheet
 SrcRng.Copy Destination:=DstSht.Range("A" & DstRow)              
    End If
Next
IfError:

'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
    Dim lastRow As Long
    lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow
End Function

'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)
    Dim lastCol As Long
    lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol
End Function

Post-16 Return First column if Second column has same Values else Second Column in Excel:

=IF(AND(F5=G5,F5=G5),F5,G5)

Post-15 Fill Interior color if it is matched with a particular String:
Private Sub Worksheet_Change(ByVal Target As Range)
Set MyPlage = Range("B1:B50")
For Each Cell In MyPlage
Select Case Cell.Value
Case Is = "Withdrawn"
Cell.EntireRow.Interior.ColorIndex = 7
Case Is = "Postponed"
Cell.EntireRow.Interior.ColorIndex = 8
Case Is = "Terms Agreed"
Cell.EntireRow.Interior.ColorIndex = 4
Case Is = "Papers Rec"
Cell.EntireRow.Interior.ColorIndex = 3
Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone
End Select
Next
End Sub

Post-15 Update Third column from second if First column has count more than 1:

UPDATE Table1 SET Table1.GTIN3 = GTIN2

WHERE (((Table1.[GTIN]) In (SELECT GTIN

FROM Table1

WHERE GTIN2 is not null and GTIN <> ""

GROUP BY GTIN

HAVING COUNT(*) > 1)));

Post-14 Generate an Excel report on same Project path:
Private Sub Command45_Click()
Dim Range As Object
Dim outputFileName As String
Dim db As DAO.Database
Set db = CurrentDb
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyy-MM-dd") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TblMatchedTb", outputFileName, True
End Sub
Post-13 Select string before the last special character:
select Left(dbo_temp_docdesc.DocName,InStrRev(dbo_temp_docdesc.DocName,'.')-1),dbo_temp_docdesc.DocName from dbo_temp_docdesc

Post-12 Convert data type into Number:

For Each c In Range("L2:L2000")

If c = "" Then GoTo Nextc

If IsNumeric(c) Then

c.Value = c.Value * 1

c.NumberFormat = "general"

End If

Nextc:

Next c

Post-11 Split rows into distinct rows :

Sub SplitCells()

'Update 20141024

Dim Rng As Range

Dim WorkRng As Range

On Error Resume Next

xTitleId = "KutoolsforExcel"

Set WorkRng = Application.Selection

Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

For Each Rng In WorkRng

lLFs = VBA.Len(Rng) - VBA.Len(VBA.Replace(Rng, vbLf, ""))

If lLFs > 0 Then

Rng.Offset(1, 0).Resize(lLFs).Insert shift:=xlShiftDown

Rng.Resize(lLFs + 1).Value = Application.WorksheetFunction.Transpose(VBA.Split(Rng, vbLf))

End If

Next

End Sub

pass the range like

Post-10 Selected rows modification and color for it:

Range(ActiveSheet.Range("L2"), ActiveSheet.Range("L2").End(xlDown)).Select

Selection.Interior.ColorIndex = 43

For more about color :
http://dmcritchie.mvps.org/excel/colors.htm

Sub TheWall()
With ActiveSheet.UsedRange.Borders
.LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
 End With
    With ActiveSheet
        .Cells.Font.Size = "10"
        ActiveSheet.Cells.HorizontalAlignment = xlLeft
          End With
        Range("A1:P1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub

Post-8 A specific Design with Example:-

1. If it is checked on AND button then output should cat and dog

2. If it is checked on OR button then output should cat or dog

3. While click on Category(Sub-Form) it will show like above scenario into down all text boxes.

Following code are usable for it ,paste this code inside the Search button:

Note : Table name is VERSION and sub form name is VERSIONs subform

Step-1

Private Sub Command6_Click()

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

Dim strFilterSQL As String

Dim strsearch As String

'strsearch = Me.Text0.Value

Dim strSQL As String

If IsNull(Me.Text0) Or Me.Text0 = "" Or Me.Text2 = "" Then

MsgBox "Please type in your search keyword.", vbOKOnly, "Keyword Needed"

Me.Text0.BackColor = vbYellow

Me.Text2.BackColor = vbYellow

Me.Text0.SetFocus

Else

'Const strSQL1 = "select code,Category from VERSION"

Select Case Frame1

'Filter record source dependant on option checked

Case 1

Me.[VERSIONs subform].Form.RecordSource = "select code,Category from VERSIONs Where ([Category] LIKE '*" & Me.Text0.Value & "*') and ([Category] LIKE '*" & Me.Text2.Value & "*')"

Case 2

Me.[VERSIONs subform].Form.RecordSource = "select code,Category from VERSIONs Where ([Category] LIKE '*" & Me.Text0.Value & "*') or ([Category] LIKE '*" & Me.Text2.Value & "*')"

End Select

Me.RecordSource = strFilterSQL

Me.Requery

Me.Text0.BackColor = vbGreen

Me.Text2.BackColor = vbGreen

' Me.[VERSIONs subform].Form.Filter = "[Category] LIKE '*" & Me.Text0.Value & "*'"

' Me.[VERSIONs subform].Form.FilterOn = True

' Me.[VERSIONs subform].Requery

End If

End Sub

paste this code inside the Category on click events

Step-2

Private Sub Category_Click()

Dim rst As DAO.Recordset

Dim strSQL As String

Dim seg As String

Dim segval As String

Dim Family As String

Dim Familyval As String

Dim clas As String

Dim clasval As String

Dim comm As String

Dim commval As String

' '===============Segment================

seg = CStr(Left(Me.Code, 2)) + "000000"

strSQL = "select Category from VERSIONs where code =" & seg & ""

Set rst = CurrentDb.OpenRecordset(strSQL)

segval = seg + " " + rst!Category

rst.Close

Set rst = Nothing

Forms![Form1].Text5.Value = segval

'===============Family======================

seg = CStr(Left(Me.Code, 4)) + "0000"

strSQL = "select Category from VERSIONs where code =" & seg & ""

Set rst = CurrentDb.OpenRecordset(strSQL)

segval = seg + " " + rst!Category

rst.Close

Set rst = Nothing

Forms![Form1].Text7.Value = segval

'==============Class========================

seg = CStr(Left(Me.Code, 6)) + "00"

strSQL = "select Category from VERSIONs where code =" & seg & ""

Set rst = CurrentDb.OpenRecordset(strSQL)

segval = seg + " " + rst!Category

rst.Close

Set rst = Nothing

Forms![Form1].Text9.Value = segval

'==============Commedity========================

seg = CStr(Left(Me.Code, 8))

strSQL = "select Category from VERSIONs where code =" & seg & ""

Set rst = CurrentDb.OpenRecordset(strSQL)

segval = seg + " " + rst!Category

rst.Close

Set rst = Nothing

Forms![Form1].Text11.Value = segval

End Sub

*********************************************************************************

Post-7 Export Access file to Excel format:-

Private Sub Command45_Click()

Dim Range As Object

Dim outputFileName As String

Dim db As DAO.Database

Set db = CurrentDb

outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyy-MM-dd") & ".xls"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TblMatchedTb", outputFileName, True

End Sub

*********************************************************************************

Post-6 Excel to MS Access converter:-

Private Sub Command0_Click()

Dim strPathFile As String, strFile As String, strPath As String

Dim strTable As String

Dim blnHasFieldNames As Boolean

Const msoFileDialogFilePicker As Long = 3

Dim objDialog As Object

Set objDialog = Application.FileDialog(msoFileDialogFilePicker)

With objDialog

.AllowMultiSelect = False

.Show

If .SelectedItems.Count = 0 Then

MsgBox "!! No file selected.Please Select One !!"

Else

For Each vrtSelectedItem In .SelectedItems

Filename = vrtSelectedItem

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "temp_input", Filename, True

' objDialog , FileName, blnHasFieldNames

Next

End If

End With

End Sub

*********************************************************************************

Post-5 Function to create auto Number in a table:-
Function CreateAutoNumberField( _

ByVal strTableName As String, _

ByVal strFieldName As String) _

As Boolean

'References: Microsoft Access 11.0 Object Library, Microsoft DAO 3.6 Object Library

'Set references by Clicking Tools and Then References in the Code View window

'Creates an Autonumber field

'strTableName : Name of table in which to create the field

'strFieldName : Name of the new field

'Returns True on success, false otherwise

'USAGE: CreateAutoNumberField "TABLENAME", "FIELDNAME"

On Error GoTo errhandler

Dim Db As DAO.Database

Dim fld As DAO.Field

Dim tdf As DAO.TableDef

Set Db = Application.CurrentDb

Set tdf = Db.TableDefs(strTableName)

' First create a field with datatype = Long Integer

Set fld = tdf.CreateField(strFieldName, dbLong)

With fld

' Appending dbAutoIncrField to Attributes

' tells Jet that it's an Autonumber field

.Attributes = .Attributes Or dbAutoIncrField

End With

With tdf.Fields

.Append fld

.Refresh

End With

CreateAutoNumberField = True

ExitHere:

Set fld = Nothing

Set tdf = Nothing

Set Db = Nothing

'MsgBox "Autonumber Complete"

Exit Function

errhandler:

CreateAutoNumberField = False

With Err

MsgBox "Error " & .Number & vbCrLf & .Description, _

vbOKOnly Or vbCritical, "CreateAutonumberField"

End With

Resume ExitHere

End Function

Note:- after creating this function paste following code into your Button

Private Sub Command0_Click()

Dim Db As DAO.Database

Set Db = CurrentDb()

CreateAutoNumberField "Table1", "GH"

End Sub

*********************************************************************************
Post-4 Update selected Combo box values in MS Access:-
'update table column and call the module function(removeSpecial)

Private Sub Command24_Click()

Dim db As DAO.Database

Set db = CurrentDb()

'If IsNull(Me.Combo20.Value) Or Me.Combo20.Value = " " Then

db.Execute "update [" + Me.Combo20.Value + "] set mfgid2=removeSpecial([mfgid])"

MsgBox "Table Column Updated"

End Sub
*********************************************************************************
Post-3 Show all table in mdb into a combobox MS Access:-

Private Sub Command42_Click()
'Set db = CurrentDb()
Dim i As Integer
' ASSIGNING THE COMBO BOX COMBO3 TO NO DISPLAY
Combo20.RowSource = ""
' CLEARING THE COMBO BOX COMBO3
Combo20 = ""
Dim db As DAO.Database, tbl As TableDef, fld As Field
Set db = CurrentDb()
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" And Mid(tbl.Name, 2, 4) <> "TMPC" Then
Combo20.AddItem tbl.Name
End If
Next tbl
End Sub
Note - If you want to refresh list after creating new table then paste this code again into new Command button.
*********************************************************************************
Post-2. MS - Access Functions:-
'Function for Revome SpeclChar
Function removeSpecial(sInput As String) As String
Dim sSpecialChars As String
Dim i As Long
sSpecialChars = "-&\/:*?""<>|@#"
For i = 1 To Len(sSpecialChars)
sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
Next
removeSpecial = sInput
End Function
*********************************************************************************
'Function for calculating Variance of Two Columns in a Table
Function VarianceCalculate(sInput1 As Integer, sInput2 As Integer)
VarianceCalculate = ((sInput1 - sInput2) / sInput1 * 100)
If (VarianceCalculate) < 1 Then
VarianceCalculate = ((sInput2 - sInput1) / sInput2 * 100)
End If
End Function
*********************************************************************************
'Function to Delete a Table if allready Exist
Function TableExists(ByVal TableName As String) As Boolean
'*************************************************
' Purpose: Checks to see whether the named table exists in the database
'
' Returns: True, if table found in current db, False if not found.
'************************************************* ****************************
Dim strTableNameCheck
On Error GoTo ErrorCode
'try to assign tablename value
strTableNameCheck = CurrentDb.TableDefs(TableName)
'If no error and we get to this line, true
TableExists = True
ExitCode:
On Error Resume Next
Exit Function
ErrorCode:
Select Case Err.Number
Case 3265 'Item not found in this collection
TableExists = False
Resume ExitCode
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "hlfUtils.TableExists"
'Debug.Print "Error " & Err.number & ": " & Err.Description & "hlfUtils.TableExists"
Resume ExitCode
End Select
End Function
*********************************************************************************

Post-1. Excel Macros:-

Delete First Rows in Single Sheet:

Sub sbVBS_To_Delete_EntireRow()

Rows(1).EntireRow.Delete

End Sub

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

Delete First Rows for all sheets

Sub LoopThroughSheets()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

ws.Range("1:1").Delete

Next ws

End Sub

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

Add Sheet Name in First column - in all Sheets

Sub Prepare_Sheet()

Dim WS As Worksheet

Dim LASTROW As Long

For Each WS In Sheets

With WS

LASTROW = .Range("A" & Rows.Count).End(xlUp).Row

.Columns(1).Insert

.Range("A1:A" & LASTROW) = WS.Name

End With

Next WS

End Sub

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

add column Name

Sub Prepare_Sheet()

Dim WS As Worksheet

Dim LASTROW As Long

For Each WS In Sheets

With WS

.Range("A1") = "SheetName"

' LASTROW = .Range("A" & Rows.Count).End(xlUp).Row

' .Columns(1).Insert

' .Range("A1:A" & LASTROW) = WS.Name

End With

Next WS

End Sub
---------------------

import to one sheet:
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

wsCombine.Cells(1, 1).EntireColumn.AutoFit

Set rg = Nothing

Set wsCombine = Nothing

End Sub

=============

Delete Empty Columns

Sub DeleteBlankColumns()

'Step1: Declare your variables.

Dim MyRange As Range

Dim iCounter As Long

'Step 2: Define the target Range.

Set MyRange = ActiveSheet.UsedRange

'Step 3: Start reverse looping through the range.

For iCounter = MyRange.Columns.Count To 1 Step -1

'Step 4: If entire column is empty then delete it.

If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then

Columns(iCounter).Delete

End If

'Step 5: Increment the counter down

Next iCounter

Columns("C:C").Select

Selection.Delete Shift:=xlToLeft

Columns("H:H").Select

Selection.Delete Shift:=xlToLeft

End Sub

=============

insert new column
Sub InsertColumns()

'PURPOSE: Insert column(s) into the active worksheet

'SOURCE: www.TheSpreadsheetGuru.com

'Insert Column to the left of Column D

Columns("D:D").Insert Shift:=xlToRight, _

CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

'Insert 2 Columns to the left of Column G

Columns("G:H").Insert Shift:=xlToRight, _

CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

End Sub

===============

Select only filled row in excel (diagonally)
Sub Select_UsedRange()

ActiveSheet.UsedRange.Select

End Sub

===============

merge all excel sheet into one

Sub simpleXlsMerger()

Dim bookList As Workbook

Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object

Application.ScreenUpdating = False

Set mergeObj = CreateObject("Scripting.FileSystemObject")

'change folder path of excel files here

Set dirObj = mergeObj.Getfolder("D:\change\to\excel\files\path\here")

Set filesObj = dirObj.Files

For Each everyObj In filesObj

Set bookList = Workbooks.Open(everyObj)

'change "A2" with cell reference of start point for every files here

'for example "B3:IV" to merge all files start from columns B and rows 3

'If you're files using more than IV column, change it to the latest column

'Also change "A" column on "A65536" to the same column as start point

Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy

ThisWorkbook.Worksheets(1).Activate

'Do not change the following column. It's not the same column as above

Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial

Application.CutCopyMode = False

bookList.Close

End Sub
===============

copy file name
Sub GetFileNames()

Dim xRow As Long

Dim xDirect$, xFname$, InitialFoldr$

InitialFoldr$ = "C:\Users\mso\Desktop\2016 Periop Inventory Final_Done" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = Application.DefaultFilePath & "\"

.Title = "Please select a folder to list Files from"

.InitialFileName = InitialFoldr$

.Show

If .SelectedItems.Count <> 0 Then

xDirect$ = .SelectedItems(1) & "\"

xFname$ = Dir(xDirect$, 7)

Do While xFname$ <> ""

ActiveCell.Offset(xRow) = xFname$

xRow = xRow + 1

xFname$ = Dir

Loop

End If

End With

End Sub

SQLjuMBLe

Menu Bar

Thursday 30 December 2021

some trick on VBA

Removing blank series from an excel chart

Excel Macro to color and formatting different series charts and labels