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:
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!!
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