Скопируйте ТОЛЬКО текст из одного диапазона и вставьте ТОЛЬКО первые три текста на другой лист

Question

У меня до 6 ячеек с потенциальными данными из 6 разных мест.Я пытаюсь получить только первые три ячейки с данными, перенесенными на другой лист

Private Sub Transfer_Data()

Sheets("sheet1").Range("A1:A6").SpecialCells(xlCellTypeConstants, 23).copy

Sheets("sheet2").Range("A1:A3").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

End Sub

Это то, что у меня есть, я знаю, что мне не хватает выделения

Answer 1

Не проверено, может быть другой, более элегантный способ сделать это:

Private Sub TransferData()

Dim cellCount as long

Dim cell as range
Dim rangeToCopy as range

For each cell in  Sheets("sheet1").Range("A1:A6").SpecialCells(xlCellTypeConstants) ' 23 is unnecessary, as you get all XlSpecialCellsValue constants by default
' See https://docs.microsoft.com/en-us/office/vba/api/excel.range.specialcells
cellCount = cellCount + cell.cells.count

If not (rangeToCopy is nothing) then
Set rangeToCopy = application.union(rangeToCopy, cell)
Else
Set rangeToCopy = cell
End if

If cellCount = 3 then exit for

Next cell

If not (rangeToCopy is nothing) then
rangeToCopy.copy

Sheets("sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

End if

End Sub

Answer 2

Я знаю, что это уже ответили, но как насчет сумасшедшего однострочника?

Sub TransferData()
    ThisWorkbook.Sheets("Sheet2").Range("A1:A3").Value2 = WorksheetFunction.Transpose(Split(Replace$(Join(WorksheetFunction.Transpose(ThisWorkbook.Sheets("Sheet1").Range("A1:A6").Value2), ","), ",,", ","), ","))
End Sub

Answer 3

Вот как бы я это сделал:

Sub Transfer_Data()

Dim i As Long, j As Long

j = 1

For i = 1 To 6
    If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
        Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
        j = j + 1
    End If

    If j > 3 Then Exit For
Next i

End Sub

РЕДАКТИРОВАНИЕ:

Sub Transfer_Data()

    Dim i As Long, j As Long

    j = 3

    For i = 1 To 6
        If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
            Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
            j = j - 1
        End If

        If j = 0 Then Exit For
    Next i

End Sub