CODEWITHSUNDEEP
excelvba
Madhuri Vairapandi
Madhuri Vairapandi

Reputation: 13

VBA code to stack multiple columns in range into one column gets Run Time Error 1004 (Paste and copy area not same size and shape)

Error Location in Code: Rng2.Offset (RowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True.

I have the text of a book currently stored in multiple columns. The range of all cells containing text is labelled "MyData". What I'm trying to do is stack all the columns into one single column of data, but right now, it only seems to be copying over one column of data to the second sheet, when prompted. I've uploaded my raw data to my [Google Drive][1], too, if anybody wants to see what I'm working with.

Sub StackDataToOneColumn()


Dim Rng1 As Range, Rng2 As Range, Rng As Range

Dim RowIndex As Long

Set Rng1 = Application.Selection

Set Rng1 = Application.InputBox("Select Range:", "StackDataToOneColumn", Rng1.Address, Type:=8)

Set Rng2 = Application.InputBox("Destination Column:", "StackDataToOneColumn", Type:=8)

RowIndex = 0

Application.ScreenUpdating = False



For Each Rng In Rng1.Rows

    Rng.Copy

    Rng2.Offset(RowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True

    RowIndex = RowIndex + Rng.Columns.Count

Next

Application.CutCopyMode = False

Application.ScreenUpdating = True


End Sub


  [1]: https://drive.google.com/file/d/1CN7KftcnLxr5WOrqx-qie4r2RplnKnil/view?usp=sharing

Upvotes: 0

Views: 177

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, test the next code and send some feedback:

Sub PutEachWordOnOneCellInAA()
   Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, lastCol As Long, arr1
   Dim rngCells As Range, arrRow, arrFin, i As Long, j As Long, k As Long
   
   Set sh1 = ThisWorkbook.Sheets("Sheet1")
   Set sh2 = ThisWorkbook.Sheets("Sheet1 (2)")
   lastR = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row

   Set rngCells = sh1.UsedRange.SpecialCells(xlCellTypeConstants) 'only cells not being empty
   ReDim arrFin(1 To rngCells.Count, 1 To 1): k = 1

   arr1 = sh1.Range("A1:A" & lastR).Value2                                'to iterate faster
   
   For i = 1 To lastR
        lastCol = sh1.Cells(i, sh1.Columns.Count).End(xlToLeft).Column
        arrRow = sh1.Range(sh1.Cells(i, "A"), sh1.Cells(i, lastCol)).Value2
        If IsArray(arrRow) Then 'if more then one column:
            For j = 1 To lastCol
              arrFin(k, 1) = arrRow(1, j): k = k + 1
            Next j
        Else                             'if only one word per A:A cell
            arrFin(k, 1) = arrRow: k = k + 1
        End If
   Next i
   sh2.Range("A1").Resize(UBound(arrFin), 1).Value = arrFin
   MsgBox "Ready..."
End Sub

Upvotes: 1

Related Questions