excel - копировать значения из таблицы в зависимости от типа значения - PullRequest
Новая
       15

excel - копировать значения из таблицы в зависимости от типа значения

0 голосов
/ 04 июля 2018

У меня есть следующая таблица в листе 1 (Экспорт): 

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

Где ctr_type - это имя листа , в которое должны быть скопированы афферентные значения.

Итак, мой вопрос: как скопировать значения в их афферентные листы.

Одним из ожидаемых результатов будет то, что все значения из таблицы, у которых есть CtrType1 в столбце ctr_type, будут скопированы в лист существующие в файле с именем CtrType1.

Спасибо!

1 Ответ

0 голосов
/ 04 июля 2018

Можно использовать что-то вроде следующего. Предполагается, что ваши данные имеют заголовки и начинаются в столбце 1, а справа от таблицы нет данных. В противном случае измените метод определения последнего столбца.

У меня есть вспомогательные функции для поиска последней строки и столбца. Я зацикливаю последний столбец, чтобы получить уникальные имена листов, хранящиеся в словаре, и в то же время добавляю диапазон слева от имени листа в словарь. Если имя листа существует в качестве ключа в словаре, я использую Union, чтобы добавить текущий диапазон слева к существующим строкам, найденным для этого имени листа.

Я перезаписываю словарь, используя ключи имени листа, чтобы записать значения в соответствующие листы. Вы должны добавить обработку ошибок, например Что делать, если листа нет? 

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
...