VBA Code to combine sheets into one

Option Explicit

Sub CopyFromWorksheets()

Dim wrk As Workbook  'Workbook object - Always good to work with object variables

Dim sht As Worksheet 'Object for handling worksheets in loop

Dim trg As Worksheet 'Master Worksheet

Dim rng As Range     'Range object

Dim colCount As Integer 'Column count in tables in the worksheets

    

    Set wrk = ActiveWorkbook 'Working in active workbook

    

    For Each sht In wrk.Worksheets

        If sht.Name = "Master" Then

            MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _

                    "Please remove or rename this worksheet since 'Master' would be" & _

                    "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"

            Exit Sub

        End If

    Next sht

    

    'We don't want screen updating

    Application.ScreenUpdating = False

    

    'Add new worksheet as the last worksheet

    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))

    'Rename the new worksheet

    trg.Name = "Master"

    'Get column headers from the first worksheet

        'Column count first

        Set sht = wrk.Worksheets(1)

        colCount = sht.Cells(1, 255).End(xlToLeft).Column

        'Now retrieve headers, no copy&paste needed

        With trg.Cells(1, 1).Resize(1, colCount)

            .Value = sht.Cells(1, 1).Resize(1, colCount).Value

            'Set font as bold

            .Font.Bold = True

        End With

    

    'We can start loop

    For Each sht In wrk.Worksheets

        'If worksheet in loop is the last one, stop execution (it is Master worksheet)

        If sht.Index = wrk.Worksheets.Count Then

            Exit For

        End If

        'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets

        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))

        'Put data into the Master worksheet

        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value

    Next sht

    'Fit the columns in Master worksheet

    trg.Columns.AutoFit

    

    'Screen updating should be activated

    Application.ScreenUpdating = True

End Sub

Map & Unmap drives via VBA

VBA Code to map and unmap a drive in the system:

Sub Map_Drive()

Dim oNetwork As Object, sDrive As String, sPath As String

Set oNetwork = CreateObject("WScript.Network")

sDrive = "A:"

sPath = "\\Server1\ABC"

oNetwork.MapNetworkDrive sDrive, sPath

sDrive = "B:"

sPath = "\\Server2\XYZ"

oNetwork.MapNetworkDrive sDrive, sPath

End Sub

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

Sub Unmap_Drive()

Dim objNetwork As Object

Set objNetwork = CreateObject("WScript.Network")

objNetwork.RemoveNetworkDrive "A:" ', bForce:=True

objNetwork.RemoveNetworkDrive "B:" ', bForce:=True

End Sub

Working with Name Manager in Excel

Name Manager makes it easy to work in Excel. With the help of Name Manager you can define a range of cells by a name and store it. You can refer to the name instead of mentioning the range every time. Here is a simple VBA code to create names.

Lets say we have the following data. Column A has the Names and column B has the formula (image below)

Use the following VBA code to create the names. If the name is already available, it will overtire.

Sub CreateDefineName()

Application.DisplayAlerts = False

Sheets("Sheet1").Activate

Row = 1

Do While Cells(Row, 1) <> ""

DName = Cells(Row, 1)

Frm = Cells(Row, 2)

ActiveWorkbook.Names.Add Name:=DName, RefersTo:=Frm

Row = Row + 1

Sheets("Sheet1").Activate

Loop

Application.DisplayAlerts = True

End Sub

VBA code to store value in a cell

VBA code to store user defined value in user defined cell(s).

Sub Test()

Dim myrange As Range

Dim mycell As Integer

Dim i As Range

On Error Resume Next

Set myrange = Application.InputBox(prompt:="enter a range of cell", Title:="Specify range", Type:=8)

For Each i In myrange

mycell = Application.InputBox(prompt:="Enter a number", Type:=1)

i = mycell

Next i

End Sub