MHAYTHAM2018

Sub TransferToRelatedSheets() Dim wks As Worksheet Dim data As Variant Dim item As Variant Dim key As Variant Dim dict As Object Dim rng As Range Dim rngBeg As Range Dim rngEnd As Range Dim cell As Range Dim x As Long Dim y As Long Set wks = ThisWorkbook.Worksheets("transfar") Set rngBeg = wks.Range("A2:E27") Set rngEnd = wks.Cells(Rows.Count, rngBeg.Column).End(xlUp) If rngEnd.Row < rngBeg.Row Then Exit Sub Set rng = wks.Range(rngBeg, rngEnd) Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare Application.ScreenUpdating = False For Each cell In rng.Columns(1).Cells key = Trim(cell) item = cell.Resize(1, rng.Columns.Count).Value item(1, 1) = CLng(item(1, 1)) If Not dict.Exists(key) Then dict.Add key, item Else data = Application.Transpose(dict(key)) x = UBound(data, 1) y = UBound(data, 2) + 1 ReDim Preserve data(1 To x, 1 To y) data = Application.Transpose(data) For x = 1 To UBound(item, 2) data(y, x) = item(1, x) Next x dict(key) = data End If Next cell For Each item In dict.Items If WorksheetExists(CStr(item(1, 1))) Then x = UBound(item, 1) y = UBound(item, 2) Set rng = Worksheets(CStr(item(1, 1))).Range("A2") rng.Resize(x, y).Value = item Range("A2:E27").ClearContents End If Next item Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub Function WorksheetExists(sheetName As String) As Boolean Dim sheet As Worksheet Dim temp As String temp = UCase(sheetName) WorksheetExists = False For Each sheet In Worksheets If temp = UCase(sheet.Name) Then WorksheetExists = True Exit Function End If Next sheet End Function