Транспонировать и вставлять в рабочий список

Question

Мне нужно транспонировать и вставлять данные из таблицы на листы («SCAN IN»). Столбец («C2: ZZ») и вставлять в последнюю строку листов («SCAN IN2»), чтобы создать рабочий список. Затем очистите стол от листов («СКАНИРОВАТЬ»)

Я установил форму для транспонирования из листов («СКАНИРОВАТЬ») и очистил содержимое листа назначения, а затем вставил данные в столбцы («C2: D»).

Sub Transfer_Transpose_Scans()
    Dim WksScanIn As Worksheet
    Dim rBinLocs As Range
    Dim rBinLoc As Range
    Dim iOutputRow As Long
    Dim iColOffset As Long
    Dim lastrow As Long


    ThisWorkbook.Activate
    Set WksScanIn = Worksheets("SCAN IN")
    On Error GoTo NoBinLocs
    Set rBinLocs = WksScanIn.Columns("C").Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
    On Error GoTo 0

    Worksheets("SCAN IN2").Activate
    Range("C2:D" & Rows.Count).ClearContents




    iOutputRow = 1

    For Each rBinLoc In rBinLocs
        iColOffset = 1
        While Len(rBinLoc.Offset(0, iColOffset).Value) > 1
            iOutputRow = iOutputRow + 1
            Cells(iOutputRow, "C").Value = rBinLoc.Value
            Cells(iOutputRow, "D").Value = rBinLoc.Offset(0, iColOffset).Value
            iColOffset = iColOffset + 1
        Wend
    Next rBinLoc

    Exit Sub
NoBinLocs:
    MsgBox "No bin locations found on " & """" & "SCAN IN" & """" & " worksheet Column c", vbInformation, "No Bin Locations Found"
End Sub

Мне нужно скопировать, транспонировать, вставить из столбца Sheets («SCAN IN»). (C2: D) в последнюю строку таблицы («SCAN IN2»). Column (c: d).

Я хочу очистить данные, которые были транспонированы и скопированы с листов («СКАНИРОВАНИЕ»).

Answer 1

Sub Transfer_Transpose_Scans()
Dim WksScanIn As Worksheet
Dim rBinLocs As Range
Dim rBinLoc As Range
Dim iOutputRow As Long
Dim iColOffset As Long
Dim lastrow As Long


ThisWorkbook.Activate
Set WksScanIn = Worksheets("SCAN IN")
On Error GoTo NoBinLocs
Set rBinLocs = WksScanIn.Columns("C").Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo 0

Worksheets("SCAN IN2").Activate
'Range("C2:D" & Rows.Count).ClearContents

iOutputRow = Cells(Rows.Count, 3).End(xlUp).Row

For Each rBinLoc In rBinLocs
    iColOffset = 1
    While Len(rBinLoc.Offset(0, iColOffset).Value) > 1
        iOutputRow = iOutputRow + 1
        Cells(iOutputRow, "C").Value = rBinLoc.Value
        Cells(iOutputRow, "D").Value = rBinLoc.Offset(0, iColOffset).Value
        iColOffset = iColOffset + 1
    Wend
Next rBinLoc

WksScanIn.Range("C2:XFD" & Rows.Count).ClearContents

Exit Sub