Merge Multiple Excel Workbook Sheets Into 1 Excel File

This VBA code will:

1. Create a new .xlsx workbook
2. Import the first worksheet for all Excel files within a specified directory
3. The final result will have the first worksheet placed in it's own tab

 

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\username\Desktop\Directory of Files" 'Change this path accordingly (Files you want imported)
    Set wbDst = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(MyPath & "\*.xlsx", vbNormal) 'Change this extension accordingly (.xlsx, .xls, .txt, etc.)
    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

End Sub

Parse Cell String Contents (VBA)

Thanks to my buddy Smitty for help on this one...

The VBA Module below will search a column of data (in this case:  Col G, Row 2 down) and take a cell's contents and convert it to a string.  It will then search the String for 2 key words (specified in the code below) and return the text value that sits 'in between'.  If the code encounters a duplicate within the cell (aka: string), it will ignore it and only return the unique value(s) between the 2 key words.  With this specific routine, it finds the instance(s) of "Component: " and "; Outcome" and counts backwards 11 spaces to return the value in between.  When re-using this code, please remember to modify the "Range" values, Component / Outcome key words (in quotes), and finally the # of characters with which to Start and End the parsed value.



Sub GetValues()

    Dim rngCell As Range
    Dim strName As String
    Dim Component As Integer
    Dim Outcome As Integer
    Dim CompleteResult As String
    Dim CurrentResult As String
    Dim ComponentCnt As Integer
    Dim RowCnt As Integer

    RowCnt = Range("G1").End(xlDown).Row
    Range("H2:H" + Trim(str(RowCnt - 1))).Select
    Selection.ClearContents

    For Each rngCell In Range("G2", Range("G1").End(xlDown))
        CompleteResult = ""
        strName = rngCell.Value

' Change the keyword values below to accomodate your "in between" criteria.
        Component = InStr(1, strName, "Component: ")
        Outcome = InStr(1, strName, "; Outcome")
        While Component > 0
            If CompleteResult <> "" Then
                CompleteResult = CompleteResult + vbLf
            End If
           
            ' Prevent Duplicates
            ' The number values in the line immediately following = spaces left and right to start the string start and finish points.
            CurrentResult = Mid(strName, Component + 11, Outcome - Component - 11)
            If InStr(CompleteResult, CurrentResult) = 0 Then
                CompleteResult = CompleteResult + CurrentResult
            End If
           
            Component = InStr(Outcome + 1, strName, "Component: ")
            Outcome = InStr(Outcome + 1, strName, "; Outcome")
        Wend
       
        rngCell.Offset(0, 1).Value = CompleteResult
    Next rngCell

    MsgBox ("DONE")
End Sub

VB MsgBox Function Example

MsgBox Function Example

This example uses the MsgBox function to display a critical-error message
in a dialog box with Yes and No buttons. The No button is specified as the
default response. The value returned by the MsgBox function depends on the
button chosen by the user. This example assumes that DEMO.HLP is a Help
file that contains a topic with a Help context number equal to 1000.

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Do you want to continue ?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "MsgBox Demonstration" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
' context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
Else ' User chose No.
MyString = "No" ' Perform some action.
End If

Hiding Sheet Tabs in Excel upon Sheet Activation

Private Sub Worksheet_Activate()
With ActiveWindow.Display WorkbookTabs = False
End With
End Sub

VBA Code to trim everything EXCEPT the last text string in a cell

'To use this UDF push Alt+F11 and go Insert>Module and paste in the code.
Push Alt+Q and save. The Function will appear under "User Defined" in the
Paste Function dialog box (Shift+F3). Use the Function as shown in the
graphic example below.

Function ReturnLastWord(The_Text As String)
Dim stGotIt As String

i = 1
Do Until stGotIt Like (" *")
stGotIt = Right(The_Text, i)
i = i + 1
Loop

ReturnLastWord = Trim(stGotIt)
End Function

Excel Macro to Insert Rows

This code will insert the specified number of rows in an Excel Spreadsheet based on user input. Row insert will take place from the current cell you have selected

Sub Add_Rows()
Dim Rng
Rng = InputBox("Enter number of rows required.")
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(Rng - 1, 0)).Select
Selection.EntireRow.Insert
End Sub

Code to send E-mail from MS Excel (Outlook or Outlook Express)

ActiveWorkbook.SendMail Recipients:="E-Mail Address"

Code to copy selected Excel Cells to Powerpoint Presentation via a Macro / Button

Sub RangeToPresentation()
'Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
' Make sure a range is selected
If Not TypeName(Selection) = "Range" Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, "No Range Selected"
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub