If you find any post useful then, please do share with others. Thanks!

Popular Posts

Contact

Email me

Need help and that also free? I like to learn this way, in case of any question or for a small task, please feel free to email me with details and example data, if required.

Wednesday, April 4, 2018

Merging multiple worksheets into one

This code is shared by EDWARD FERKING JR
Special Thanks to him for sharing this. true-north-usa.com  (His Company Website)

We can use below VBA code for same.

Each time we run it, it will insert a new worksheet at the far left of the active workbook and it will vertically summarize (Values and Formats only…aka a static snapshot of) all the worksheets in the active workbook (NOT including any other worksheet summary pages previously generated by the macro).

Sub SummarizeWorkSheets()
Dim wks As Worksheet, sWks As Worksheet, Ur As Range, I As Integer
Dim sWksc As Integer, sWksr As Long, CurrDate As Date, DateStr As String
Application.ScreenUpdating = False: Sheets(1).Select
Set sWks = ActiveWorkbook.Worksheets.Add: CurrDate = Now()
DateStr = Application.Text(CurrDate, "mm dd yyyy hhmmss AM/PM")
sWks.Name = "WbSumry " & DateStr
sWks.Cells(1, 1) = "Workbook Summary of All Worksheets as of " & DateStr
sWks.Cells(1, 1).Font.Size = 22: sWks.Cells(3, 1).Select: ActiveWindow.FreezePanes = True
For Each wks In ActiveWorkbook.Worksheets
If (Not wks.Name Like "WbSumry*") Then
sWks.Activate
sWksr = sWks.UsedRange.Rows.Count: sWksc = sWks.UsedRange.Columns.Count
If sWksc < 40 Then sWksc = 40
sWks.Cells(sWksr + 3, 1) = "Values and Formats From Worksheet [ " & wks.Name & " ]"
sWks.Cells(sWksr + 3, 1).Font.Size = 14
With sWks.Range(Cells(sWksr + 2, 1), Cells(sWksr + 2, sWksc)).Borders(xlEdgeBottom)
.LineStyle = xlDouble: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlThick
End With: wks.Activate: Set Ur = wks.UsedRange: Ur.Select: Selection.Copy
sWks.Activate: sWks.Cells(sWksr + 5, 1).Select:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
sWksr = sWks.UsedRange.Rows.Count: sWksc = sWks.UsedRange.Columns.Count
End If: sWks.Activate:: Next wks
sWks.Cells(1).Select: ActiveWindow.ScrollRow = 1: Application.ScreenUpdating = True
MsgBox ("Worksheet Summary Complete")
End Sub

Tuesday, March 13, 2018

VBA: SQL Connection String and Some Data Formatting

'The below code is for data formatting to use in a SQL query
'We are using connection string to pull data using SQL query
'In comments, below, the code is explained. This is also for future reference, we can copy blocks and use

Sub Amiq()
Sheets("New").Columns("A").ClearContents
Sheets("New").Columns("B").ClearContents
'The above lines clear the contents of A Worksheet namely 'New' from Columns A & B
Sheets("AuditPortal").Columns("R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("New").Columns("A"), Unique:=True
'The above line copies the column 'R' from Worksheet namely 'AuditPortal', removes duplicates  and paste it in Sheet 'New' and Column A
ThisWorkbook.Worksheets("New").Select
'Select the Sheet 'New'
'In below lines we are using For Loop and for all the Column A rows starting from 2, storing their value in variable SDest after adding single quotes and comma along
'and then along doing some more formatting i.e. Left and Len Function to remove the last comma and adding a single quote at start and finally pasting it in Column 2's first cell
SDest = ""
For iCounter = 2 To WorksheetFunction.CountA(Columns(1))
SDest = SDest & "'" & Cells(iCounter, 1).Value & "'" & ","
Next iCounter
Cells(1, 2).Value = "'" & Left(SDest, Len(SDest) - 1) & ")"

'Below is the SQL connection string. We are first selecting the sheet namely 'sqlResult'
'Our SQL is pasted in Cells(1, 2) of same sheet
'Clearing the range a5:i1000 as we want our results to appear there. A to I range is determined after looking at the columns in our select statement SQL
'Change the name of server from 'OurServer'
ThisWorkbook.Worksheets("sqlResult").Select
Dim sql
sql = Sheets("sqlResult").Cells(1, 2)
Range("a5:I1000") = ""
Dim connString
connString = "ODBC;DSN=OurServer;Description=OurServer;Trusted_Connection=Yes"
Dim thisQT As QueryTable
With ActiveSheet.QueryTables.Add(Connection:=connString, Destination:=Range("a5"))
.BackgroundQuery = False
.sql = sql
.Refresh BackgroundQuery:=True
End With
End Sub

Sunday, January 7, 2018

VBA Code to Combine multiple workbooks in one workbook sheet

We can use the below code to combine multiple workbook in a sheet of single workbook and then save it as well.
 
We first need to have all the workbooks in one folder, they should have same headers. Then open a new workbook and add the below code in a module and run it.
 
We just need to change the path of folder where we have multiple workbooks and then the second path where we will save new file.
 
Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Users\khan\Desktop\Weekly Snaps\" 'Path address
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)

If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True


    Dim i As Integer
    Dim xTCount As Variant
    Dim xWs As Worksheet
    On Error Resume Next

    xTCount = 1
    Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
    xWs.Name = "Combined"
    Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
    For i = 2 To Worksheets.Count
        Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
               Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
    Next
   
   
    Dim xWs2 As Worksheet
     Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    For Each xWs2 In Application.ActiveWorkbook.Worksheets
        If xWs2.Name <> "Combined" Then
            xWs2.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ActiveWorkbook.SaveAs Filename:="C:\Users\khan\Desktop\Example.xlsx" 'Path address
End Sub

Wednesday, August 23, 2017

Automatic emails outlook- Excel VBA


Automatic emails outlook- Excel VBA

In this post, I want to share a VBA code/Macro that first formats data in Excel sheet, saves it with today’s date and composes the Email in outlook, adds attachment and body so before it is sent, you take a quick glance and then press the send button.

The example file can be downloaded.

VBA code is saved in this file (Module 1) and can be run manually by clicking on Developer tab > VBA > Module 1 and run button (used to run code).

So we have a file with three sheets, the first one namely ‘Summary’ have a pivot summarizing data that we want to include in our email body.

In second sheet, we have raw data that is the basis of our summary pivot. From here we will compile the email list to whom we want to send email.

In sheet3, the email list compilation will work behind the scenes with VBA.

So our VBA code, mentioned below, will do following.

> First it will go to Sheet3 and clear contents from A,B and C Column if any.

> Copy the email addresses from columns E & G of Sheet Summary, combines them, removes duplicates and save them in Column C of Sheet 3.

> Arranges EMAIL addresses in order i.e. separated by “;”, and then clears the contents of Sheet3’s column C.

> Saves the File at specified location and name with current date. Note: In this part of code, you need to update the file location and name as per your requirement.

> Now the Summary sheet’s data will be copied in EMAIL body and TO and CC email addresses, and file attachment, will be added. Note: Here you need to change the CC email address as per need or remove the CC line.

 

VBA Code

Sub Send_Range()
Sheets("sheet3").Columns("A").ClearContents
Sheets("sheet3").Columns("B").ClearContents
Sheets("sheet3").Columns("C").ClearContents
Sheets("Raw").Columns("E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("sheet3").Columns("A"), Unique:=True
Sheets("Raw").Columns("G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("sheet3").Columns("B"), Unique:=True
Dim oneColumnHead As Range
Dim columnHeads As Range
With ThisWorkbook.Sheets("sheet3")
    Set columnHeads = Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft))
End With 

For Each oneColumnHead In columnHeads
    With oneColumnHead.EntireColumn
        With Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
            .Parent.Cells(.Parent.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, 1).Value = .Value
        End With
    End With
Next oneColumnHead 

Sheets("Sheet3").Columns("A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("sheet3").Columns("C"), Unique:=True
Sheets("sheet3").Columns("A").ClearContents
Sheets("sheet3").Columns("B").ClearContents 
ThisWorkbook.Worksheets("Sheet3").Select
     SDest = ""
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3)) + 200
       If (Cells(iCounter, 3).Value <> "" And Cells(iCounter, 3).Value <> "NULL") Then
           If SDest = "" Then
               SDest = Cells(iCounter, 3).Value
           Else
               SDest = SDest & ";" & Cells(iCounter, 3).Value
           End If
           End If
       Next iCounter


Sheets("sheet3").Columns("C").ClearContents 

ActiveWorkbook.SaveAs Filename:="C:\Users\amiqullahkhan\Desktop\SalesAudit " & Format(Now(), "DD-MMM-YYYY") & ".xlsm", FileFormat:=52
'Update the File address and name as per your need
   Dim OutApp As Object
    Dim OutMail As Object
      Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
     ThisWorkbook.Activate
   fname = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
 Worksheets("Summary").Activate
  Dim num As Integer
  Dim Copyrange
  Dim rng As Range
  num = WorksheetFunction.CountA(Columns(1))
  Let Copyrange = "A" & 1 & ":" & "C" & num
Set rng = Sheets("Summary").Range("A" & 1 & ":" & "C" & num).SpecialCells(xlCellTypeVisible) 

With OutMail
      'Debug.Print SDest
      'With .Item
        .To = SDest
        .CC = "Amiq Ullah <Amiqullah@gmail.com>"
        .Subject = "Sales Compliance Audit"
        .Attachments.Add fname
        .HTMLBody = RangetoHTML(rng)
        .DISPLAY
      End With
   'End With
   'MsgBox (TimeOfDay)
   Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"    'Copy the range and create a new workbook to past the data in


    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

Tuesday, August 22, 2017

Pull Unique Values with Advanced Filter

Pull Unique Values with Advanced Filter
 
Though there are many ways of removing duplicates, I just wanted to share a use of Advanced filter for same.
We can use advanced filter to pull non duplicate items from a column(s).
For this go to Data tab and then click on Advanced.
A dialog box will open. Here choose the option of Copy to another location. In list Range box, mention the range from which we want to extract unique values. And in Copy to box, the place where we want our unique list to appear.
Then check the box of unique records only. Now click on ok.
And we have now two lists the original along new one having just unique items.
Note: There is no link between original data and filtered data so in case original data changes, the advanced filter must be run again.