Переместить выделение в нижнюю часть соответствующего столбца в Excel VBA - PullRequest
Новая
       11

Переместить выделение в нижнюю часть соответствующего столбца в Excel VBA

0 голосов
/ 28 апреля 2018

Если у меня есть данные в 5 столбцах (A-F), и я выбираю разные ячейки в этих столбцах, я хотел бы макрос, который бы перемещал содержимое этих ячеек в соответствующие столбцы 12-й строки.

Например: A3, B2, B4, C4, D1, D2, F4 Их содержимое должно быть в A12, B12, C12, D12, F12, разделенных символом «,».

Это почти делает работу, но не работает, если я выбираю материал из более чем 1 столбца: 

Sub Move()

Dim selectedCells As Range
Dim rng As Range
Dim i As Integer
Dim values() As String
Dim CSV As String

Set selectedCells = Selection
ReDim values(selectedCells.Count - 1)

i = 0
For Each rng In selectedCells
    values(i) = CStr(rng.Value)
  i = i + 1
Next rng

CSV = Join(values, ", ")

Dim vArr
vArr = Split(Selection.Address(True, False), "$")
SC = vArr(0)

Range(SC & "12").Value = CSV
Selection.ClearContents

End Sub

Заранее спасибо за помощь!

Ответы [ 2 ]

0 голосов
/ 29 апреля 2018

другая возможность: 

Sub Move()
    Dim cell As Range, cell2 As Range

    For Each cell In Selection
        With Cells(12, cell.Column)
            If IsEmpty(.Value) Then
                For Each cell2 In Intersect(.EntireColumn, Selection)
                    .Value = .Value & " " & cell2.Value
                Next
                .Value = Join(Split(Trim(.Value), " "), ",")
            End If
        End With
    Next
    Selection.ClearContents
End Sub
0 голосов
/ 28 апреля 2018

Использование Selection не рекомендуется, но если вы хотите использовать этот подход, как насчет чего-то подобного? 

Sub Move()

Dim selectedCells As Range
Dim rng As Range
Dim targetRng As Range

Set selectedCells = Selection

For Each rng In selectedCells
    Set targetRng = Cells(12, rng.Column)
    If IsEmpty(targetRng) Then
        targetRng = rng
    Else
        targetRng = targetRng & ", " & rng
    End If
    rng.ClearContents
Next rng

End Sub
...