Wednesday, March 16, 2016

Excel VBA Macro to copy data from two sheets to third sheet

Query: I want to copy data from two two sheets to third sheet, I have sheet 1 & sheet 2 having multiple columns & rows, some columns in both the sheet have same header, i want to copy few of them to third sheet. So match haeding in sheet 1  copy all data till last row and paste it to last sheet, same for sheet2. Copy data for all column header in last sheet.

Solution:
Make sure haeader in all sheet is similar & we can make macro to search through header in sheet 1/Sheet 2 & if header matches copy data from sheet 1 & paste it to last sheet.

Use below code:
Option Explicit

Sub copy_data_from _two_sheets_to_Summary_sheet()

    Dim Rng As Range, c As Range

    Dim sCell As Range

    Dim rSize As Long

    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet

  

    Set sh1 = Sheets("File 1")

    Set sh2 = Sheets("File 2")

    Set sh3 = ThisWorkbook.ActiveSheet

  

    sh3.[A2].Resize([A2].End(xlDown).Row - 1, 1).EntireRow.Clear

    Set Rng = sh3.Range([A1], [A1].End(xlToRight))

    For Each c In Rng

        'Copy data from Sheet 1

        Set sCell = sh1.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)

        If Not sCell Is Nothing Then

        rSize = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

        If c.Offset(1, 0).Value <> "" Then

            c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

        Else

            c.Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

        End If

        End If

      

        'Copy data from Sheet 2

        Set sCell = sh2.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)

        If Not sCell Is Nothing Then

        rSize = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

        If c.Offset(1, 0).Value <> "" Then

            c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

        Else

            c.Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

        End If

        End If

      

    Next

  

    MsgBox "Done"

End Sub


Cheers!!

1 comment:

  1. At the same time, shall be able|it is feasible for you to} to unlock a host of promotional deals and offers, including that all-important, lucrative welcome bonus. This can then be spent elsewhere on the site and is a fantastic start line in your journey. From right 메리트카지노 here, have the ability to|you possibly can} target increasingly lucrative games and offers, steadily build up your stability till you hit that coveted jackpot. A minimum deposit of $/€20 will be required to set off the bonus.

    ReplyDelete