Sub CallCopyDataAndFormatHeaders()
Dim sourceSheetName As String
Dim targetSheetName As String
' Modify the sheet names as needed
sourceSheetName = "issues"
targetSheetName = "combined"
' Call the subroutine to copy and format data
CopyDataAndFormatHeaders sourceSheetName, targetSheetName
' Call the CopyMatchingData subroutine with the desired parameters
CopyAndColorHeaders "Action Plan", "combined", "green"
End Sub
Sub CopyDataAndFormatHeaders(sourceSheetName As String, targetSheetName As String)
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastColumn As Long
' Set references to the source and target sheets
Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
Set targetSheet = ThisWorkbook.Sheets(targetSheetName)
' Clear existing data in the target sheet
targetSheet.Cells.Clear
' Copy data from the source sheet to the target sheet
sourceSheet.Cells.Copy targetSheet.Range("A1")
' Copy header row from source to target
sourceSheet.Rows(1).Copy targetSheet.Rows(1)
' Copy header row from source to target
sourceSheet.Rows(2).Copy targetSheet.Rows(2)
' Set the background color of header cells in target sheet
Dim lastCol As Long
lastCol = targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column
targetSheet.Range(targetSheet.Cells(1, 1), targetSheet.Cells(2, lastCol)).Interior.color = RGB(200, 200, 200) ' Gray color for header cells
' Autofit columns in the target sheet
targetSheet.Cells.EntireColumn.AutoFit
' Clean up
Set sourceSheet = Nothing
Set targetSheet = Nothing
End Sub
Sub CopyAndColorHeaders(sourceSheetName As String, targetSheetName As String, Optional color As String = "blue")
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceHeaderRange As Range
Dim targetHeaderRange As Range
Dim lastColumn As Long
' Set references to the source and target sheets
On Error Resume Next
Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
Set targetSheet = ThisWorkbook.Sheets(targetSheetName)
On Error GoTo 0
If sourceSheet Is Nothing Then
MsgBox "Source sheet '" & sourceSheetName & "' not found!", vbExclamation
Exit Sub
End If
If targetSheet Is Nothing Then
MsgBox "Target sheet '" & targetSheetName & "' not found!", vbExclamation
Exit Sub
End If
' Find the last column in the target sheet
lastColumnSource = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
' Find the last column in the target sheet
lastColumn = targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column
' Copy the headers from source sheet row 1 and row 2
Set sourceHeaderRange = sourceSheet.Range(sourceSheet.Cells(1, 1), sourceSheet.Cells(2, lastColumnSource))
Set targetHeaderRange = targetSheet.Range(targetSheet.Cells(1, lastColumn + 1), targetSheet.Cells(2, lastColumn + 1 + sourceHeaderRange.Columns.Count - 1))
sourceHeaderRange.Copy targetHeaderRange
' Apply the specified color to the newly pasted header rows
Select Case LCase(color)
Case "blue"
targetHeaderRange.Interior.color = RGB(173, 216, 230) ' Light Blue
Case "green"
targetHeaderRange.Interior.color = RGB(144, 238, 144) ' Light Green
Case "orange"
targetHeaderRange.Interior.color = RGB(255, 204, 153) ' Light Orange
Case Else
MsgBox "Invalid color specified. Defaulting to light blue.", vbExclamation
targetHeaderRange.Interior.color = RGB(173, 216, 230) ' Light Blue
End Select
End Sub
Sub TestCopyData()
CopyDataToTargetSheet "Action Plan", "combined", "Parent Objects", "Unique ID"
End Sub
Sub CopyDataToTargetSheet(ByVal sourceSheetName As String, ByVal targetSheetName As String, ByVal sourceColumnName As String, ByVal targetColumnName As String)
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceLastRow As Long
Dim targetLastRow As Long
Dim sourceColumnIndex As Long
Dim targetColumnIndex As Long
Dim sourceCell As Range
Dim targetCell As Range
Dim sourceDataRange As Range
Dim targetDataRange As Range
' Get references to source and target sheets
On Error Resume Next
Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
Set targetSheet = ThisWorkbook.Sheets(targetSheetName)
On Error GoTo 0
If sourceSheet Is Nothing Then
MsgBox "Source sheet '" & sourceSheetName & "' not found.", vbExclamation
Exit Sub
End If
If targetSheet Is Nothing Then
MsgBox "Target sheet '" & targetSheetName & "' not found.", vbExclamation
Exit Sub
End If
' Find the positions of source and target columns
On Error Resume Next
sourceColumnIndex = Application.WorksheetFunction.Match(sourceColumnName, sourceSheet.Rows(1), 0)
targetColumnIndex = Application.WorksheetFunction.Match(targetColumnName, targetSheet.Rows(1), 0)
On Error GoTo 0
If sourceColumnIndex = 0 Then
MsgBox "Source column '" & sourceColumnName & "' not found in '" & sourceSheetName & "'.", vbExclamation
Exit Sub
End If
If targetColumnIndex = 0 Then
MsgBox "Target column '" & targetColumnName & "' not found in '" & targetSheetName & "'.", vbExclamation
Exit Sub
End If
' Determine the last row of data in the source and target sheets
sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, sourceColumnIndex).End(xlUp).Row
targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, targetColumnIndex).End(xlUp).Row
' Set the data ranges
Set sourceDataRange = sourceSheet.Range(sourceSheet.Cells(2, sourceColumnIndex), sourceSheet.Cells(sourceLastRow, sourceColumnIndex).EntireRow)
Set targetDataRange = targetSheet.Range(targetSheet.Cells(2, targetColumnIndex), targetSheet.Cells(targetLastRow, targetColumnIndex).EntireRow)
' Loop through the source data and copy it to the target sheet
For Each sourceCell In sourceDataRange.Columns(sourceColumnIndex).Cells
Dim matchValue As Variant
matchValue = sourceCell.Value
' Find the matching cell in the target sheet
On Error Resume Next
Set targetCell = targetDataRange.Columns(targetColumnIndex).Find(What:=matchValue, LookIn:=xlValues, LookAt:=xlWhole)
On Error GoTo 0
' If a match is found, copy the entire row from the source sheet to the target sheet
If Not targetCell Is Nothing Then
Dim targetRow As Long
targetRow = targetCell.Row
sourceCell.EntireRow.Copy
targetSheet.Cells(targetRow, targetColumnIndex).End(xlToRight).Offset(0, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next sourceCell
End Sub
