Option Explicit
Sub CompileData()
Dim rngToCompile As Range
Dim rngArea As Range
Dim i As Long
Dim wksName As String
Dim r As Long
Dim MySheets
Dim wksCompile As Worksheet
Dim rCell As Range
Set wksCompile = Worksheets("Compilation")
MySheets = Array("CH1", "CH2", "CH3", "CH4", "CH5", "CH6", "CH7") '< adjust sheet names here
Application.ScreenUpdating = 0
For i = LBound(MySheets) To UBound(MySheets)
With Sheets(CStr(MySheets(i)))
On Error Resume Next
Set rngToCompile = .Columns(2).SpecialCells(2, 1)
On Error GoTo 0
If Not rngToCompile Is Nothing Then
For Each rngArea In rngToCompile.Areas
If Len(rngArea.Cells(1).Offset(-1, 1)) Then
wksName = rngArea.Cells(1).Offset(-1, 1)
Else
wksName = rngArea.Cells(1).Offset(-1, -1)
End If
For Each rCell In rngArea
If ISEXIST(Sheets(CStr(wksName)).UsedRange.Columns("a:b").Value, MySheets(i) & ";" & CLng(rCell.Value)) Then GoTo Nxt
Next
rngArea.Offset(, -1).Resize(, 3).Copy
With Sheets(CStr(wksName))
r = .Range("a" & .Rows.Count).End(xlUp).Offset(1).Row
.Range("a" & r).PasteSpecial -4104
.Range("a" & r).Resize(rngArea.Rows.Count).Value = MySheets(i)
End With
With Sheets("Compilation")
r = .Range("a" & .Rows.Count).End(xlUp).Offset(1).Row
.Range("a" & r).Value = MySheets(i)
.Range("a" & r).Offset(1).PasteSpecial -4104
End With
Nxt:
Next
Set rngToCompile = Nothing
End If
End With
Next
Xit:
Set wksCompile = Nothing
Set rngToCompile = Nothing
With Application
.ScreenUpdating = 1
.CutCopyMode = 0
End With
End Sub
Function ISEXIST(ByRef varData As Variant, ByVal strConcated As String) As Boolean
Dim strConcat As String, i As Long
ISEXIST = False
For i = 1 To UBound(varData, 1)
On Error Resume Next
strConcat = varData(i, 1) & ";" & CLng(varData(i, 2))
On Error GoTo 0
If LCase$(strConcat) = LCase$(strConcated) Then
ISEXIST = True
Exit Function
End If
Next
End Function
|