Ввод для диапазона

Question

Не совсем уверен, что не так с моим кодом, но он не печатается в одном прямом столбце.Это работает, когда вы говорите

cells(i,j).copy
range(i,j).pastespecial

, но выбрасывает значения в ячейках, которые являются абсолютно случайными, когда вы запрашиваете диапазон значений, например

set rng=Application.inputbox(" Please select range", Type=:8)

Все работает, кроме тех случаев, когда вы запрашиваете пользователячтобы выбрать диапазон.

Sub select1()

Dim rng As Variant
Dim i, j, k As Integer

Set rng = Application.InputBox("please select range", Type:=8)

With ActiveSheet
  i = 1
  k = 1
  For j = 1 To rng.Columns.Count
     For i = 1 To rng.Rows.Count
       rng(Cells(i, j)).Copy
       Range("l" & k).PasteSpecial
       k = k + 1
     Next i
     i = 1
 Next j
End With

End Sub

Так что для этой таблицы

jenny   doon    felix   spi gav benj    amanda
jenny   doon    felix   spi gav benj    amanda
jenny   doon    felix   spi gav benj    amanda
jenny   doon    felix   spi gav benj    amanda
jenny   doon    felix   spi gav benj    amanda
jenny   doon    felix   spi gav benj    amanda

Я должен получить (в 1 столбце)

jenny
jenny
jenny
jenny
jenny
doon
doon
doon
doon
doon
felix
felix
felix
felix
felix
spi
spi
spi
spi
spi
gav
gav
gav
gav
gav
benj
benj
benj
benj
benj

Answer 1

Это еще один подход, основанный на массивах, который может быть полезен в других ваших общих приложениях.Эта подпрограмма может передавать данные в sheet2.Однако я прокомментировал использование 2-го листа и использовал только активный лист.Вы можете изменить ссылки согласно вашему требованию.Он работает правильно для меня, и соответствующий файл доступен для вашей ссылки на Dropbox.

   Sub FillWS3()
    Dim i As Long, j As Long, currentRow As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rng As Range
    Dim period As Variant
    Dim trperiod As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet
    ' Set references to worksheets
    Set ws1 = ThisWorkbook.Worksheets("Worksheet1")
    Set ws2 = ThisWorkbook.Worksheets("Worksheet2")
      ' Determine last row in column A in worksheet1
    lastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
      ' Determine last column in column A in worksheet1
    lastCol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    currentRow = 1
    i = 1

    Set rng = Application.InputBox("please select range", Type:=8)
    period = rng.Value
    'period = ws1.Range(Cells(1, 1), Cells(lastRow, lastCol)).Value
    trperiod = Application.Transpose(period)

    For i = LBound(trperiod, 1) To UBound(trperiod, 1)
        For j = LBound(trperiod, 2) To UBound(trperiod, 2)
            ws1.Cells(currentRow, 12).Value = trperiod(i, j)
            currentRow = currentRow + 1
        Next j
    Next i
End Sub

Полученные результаты

РЕДАКТИРОВАТЬ: Согласно @PEHХорошее предложение: я удалил метод Transpose и изменил цикл массива.Отредактировал код следующим образом.

   Sub FillWS3()
    Dim i As Long, j As Long, currentRow As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rng As Range
    Dim period As Variant
    Dim trperiod As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet
    ' Set references to worksheets
    Set ws1 = ThisWorkbook.Worksheets("Worksheet1")
    Set ws2 = ThisWorkbook.Worksheets("Worksheet2")
      ' Determine last row in column A in worksheet1
    lastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
      ' Determine last column in column A in worksheet1
    lastCol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    currentRow = 1
    i = 1

    Set rng = Application.InputBox("please select range", Type:=8)
    period = rng.Value
    'period = ws1.Range(Cells(1, 1), Cells(lastRow, lastCol)).Value
    'trperiod = Application.Transpose(period)

    For j = LBound(period, 2) To UBound(period, 2)
        For i = LBound(period, 1) To UBound(period, 1)
            ws1.Cells(currentRow, 12).Value = period(i, j)
            currentRow = currentRow + 1
        Next i
    Next j
End Sub

Answer 2

Это

rng(Cells(i, j)).Copy
Range("L" & k).PasteSpecial

должно быть

rng.Cells(i, j).Copy
.Range("L" & k).PasteSpecial

или

rng.Cells(i, j).Copy Destination:=.Range("L" & k)

---

Или, если вы хотите скопировать только значение, это будетеще лучше:

.Range("L" & k).Value = rng.Cells(i, j).Value

---

В общей сложности я рекомендую следующее

• Ввести некоторую обработку ошибок для вашего Application.InputBox, иначе произойдет сбой, если пользователь нажимает клавишу Кнопка "Отмена" .

• Проверка, выбраны ли несколько областей (мы не знаем, как с ними обращаться, поэтому нам нужно запретить их).

• Использовать массивы: считать исходный диапазон в массив SrcArr = SrcRng.Value и использовать массив для вывода ReDim DestArr(1 To SrcRng.Cells.Count, 1 To 1) As Variant.Таким образом, у вас есть только одно действие чтения / записи в ячейке, которое делает ваш код намного быстрее.Преобразование полностью выполняется в массивах.

Таким образом, вы получите…

Option Explicit

Public Sub TransformRange()
    Dim SrcRng As Range
    On Error Resume Next 'next line throws error if user presses cancel so hide all errors
    Set SrcRng = Application.InputBox("please select range", Type:=8)
    On Error GoTo 0 'don't forget to re-activate error reporting

    If SrcRng Is Nothing Then Exit Sub

    If SrcRng.Areas.Count > 1 Then
        MsgBox "More than one area was selected I'm not sure what to do"
        Exit Sub
    End If

    'read everything into an array
    Dim SrcArr() As Variant
    SrcArr = SrcRng.Value

    'transform values
    ReDim DestArr(1 To SrcRng.Cells.Count, 1 To 1) As Variant
    Dim iRow As Long, iCol As Long, iArr As Long
    iArr = 1 'initialize

    For iCol = 1 To UBound(SrcArr, 2)
        For iRow = 1 To UBound(SrcArr, 1)
            DestArr(iArr, 1) = SrcArr(iRow, iCol)
            iArr = iArr + 1
        Next iRow
    Next iCol

    'write values into sheet
    SrcRng.Parent.Range("L1").Resize(RowSize:=UBound(DestArr, 1)).Value = DestArr
    'SrcRng.Parent <-- this represents the sheet of the selected range
End Sub