excel - Copy values from table depending on value

Question

I have the following table in sheet1(Export):

-----------------------------
| col1 | col2 |..cN..|ctr_type|
-----------------------------
|value |value |valueN|CtrType1|
-----------------------------
|value |value |valueN|CtrType2|
-----------------------------
|value |value |valueN|CtrType3|
-----------------------------
|value |value |valueN|CtrType1|
-----------------------------
|value |value |valueN|CtrType3|
-----------------------------
|value |value |valueN|CtrType2|
-----------------------------

Where ctr_type is the name of the sheet in which the afferent values must be copied.

So my question is: how to copy values in their afferent sheets.

One expected output would be that all the value from the table which have CtrType1 in the column ctr_type would be copied in a existin sheet with the name CtrType1.

Thank you!

Answer 1

Could use something like the following. Assumes you data has headers and starts in column 1 and that there is no data to the right of the table. Otherwise, change the method for determining the last column.

I have helper functions to find the last row and column. I loop the last column to get the unique sheet names stored in a dictionary and at the same time add the range to the left of the sheet name into the dictionary. If the sheet name exists as a key in the dictionary, I use Union to add the current range to the left to the existing rows found for this sheet name.

I re-loop the dictionary using the sheet name keys to write the values to the appropriate sheets. You should add error handling e.g. what if sheet is not present?

Option Explicit
Public Sub WriteValues()
    Dim rng As Range, ws As Worksheet, loopRange As Range, sheetDict As Object
    Set ws = ActiveSheet: Set sheetDict = CreateObject("Scripting.Dictionary")
    With ws
        Set loopRange = Range(.Cells(2, GetLastColumn(ws, 1)), .Cells(GetLastRow(ws, 1), GetLastColumn(ws, 1)))
        For Each rng In loopRange
            If Not sheetDict.Exists(rng.Value) Then
                Dim tempRange As Range
                Set tempRange = .Range(.Cells(rng.Row, 1), .Cells(rng.Row, GetLastColumn(ws, 1) - 1))
                sheetDict.Add rng.Value, tempRange.Address
            Else
                Set tempRange = Union(.Range(sheetDict(rng.Value)), .Range(.Cells(rng.Row, 1), .Cells(rng.Row, GetLastColumn(ws, 1) - 1)))
                sheetDict(rng.Value) = tempRange.Address
            End If
        Next rng
        For Each rng In loopRange
            Set tempRange = .Range(sheetDict(rng.Value))
            If Not tempRange Is Nothing Then
                tempRange.Copy Worksheets(rng.Value).Range("A" & GetLastRow(Worksheets(rng.Value), 1))
            End If
        Next rng
    End With
End Sub

Public Function GetLastColumn(ByVal ws As Worksheet, Optional ByVal rowNumber As Long = 1) As Long
    With ws
        GetLastColumn = .Cells(rowNumber, .Columns.Count).End(xlToLeft).Column
    End With
End Function

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function