Combine data into one column

John.McLaughlin

Board Regular
Joined
Jul 19, 2011
Messages
154
Hello,

I sell goods and services, and keep a table by part no of each item needed to complete the order – “the packing list”. It works great if there is only one item sold.

When there are multiple items on the order, I need to combine the table into a single column.

Here is the full code. It keeps pasting the columns instead of finding the last empty row in Column A

Thanks in advance!



Code:
Sub PostPackingList()


' PackingListPost - post from OPEN ORDER PackingList SS to Scheduled PackingList SS
'
'
   ' Copy items to sheet.
   '
   '
   Application.ScreenUpdating = False
  
   Dim wbTarget            As Workbook 'workbook where the data is to be pasted SCHEDULED:PackingList
   Dim wbThis              As Workbook 'workbook from where the data is to copied Open Order"PackingList
   Dim strName             As String   'name of the source sheet/ target workbook
   Dim filelink            As String   ' name of workbook
   Dim targetFile As String
  
' ----------------- Find last row
    Dim DstRng As Range
    Dim DstWks As Worksheet
    Dim LastRow As Long
    Dim N As Long, r As Long
    Dim SrcRng As Range
    Dim SrcWks As Worksheet
' ------------------ End find last row

   'set to the current active workbook (the source book is the Open Order)
   Set wbThis = ActiveWorkbook

      'get the active sheetname of the Open Order workbook
   strName = ActiveSheet.Name
   

    ' Activate the Scheduled Workbook and select the PackingList worksheet
    Workbooks("SCHEDULED.xlsm").Activate
    Set wbTarget = ActiveWorkbook
    Sheets("PackingList").Select

 
   'activate the Open Order source book
   wbThis.Activate
   
     
  ' copy the range from source book
    wbThis.Sheets("PackingList").Range("A5:Z5").Copy
    

' Assign the Worksheets
        Set SrcWks = wbThis.Sheets("PackingList")
        Set DstWks = wbTarget.Sheets("PackingList")
       
' Get all cells in the Source Range starting with row 5
        Set SrcRng = SrcWks.Range("A5:Z5")
        LastRow = SrcWks.Cells(Rows.Count, "B").End(xlUp).Row
        If LastRow < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcRng.Resize(LastRow - SrcRng.Row + 1, 26)
       
       
' Find the next empty row in the Destination Range starting at row 3
       
        Set DstRng = DstWks.Range("A3:A3")
        LastRow = DstWks.Cells(Rows.Count, "A").End(xlUp).Row
        Set DstRng = IIf(LastRow < DstRng.Row, DstRng, DstRng.Offset(LastRow - DstRng.Row + 1, 0))
       
          ' Copy the Source cells to the next empty Destination row if the Source Cell in "A" is not empty
         
            For r = 1 To SrcRng.Rows.Count
                If SrcRng.Cells(r, "A") <> "" Then
                    DstRng.Offset(N, 0).Resize(, 5).Value = SrcRng.Rows(r).Value
                  
                   N = N + 1
                End If
            Next r
       
   'save the target book
   wbTarget.Save

   'activate the source book again
   wbThis.Activate
   Sheets("ORDER").Select
   


Application.CutCopyMode = False
Application.ScreenUpdating = True
Range("A1").Select

ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False
       
Set wbTarget = Nothing
Set wbThis = Nothing


End Sub
 

John.McLaughlin

Board Regular
Joined
Jul 19, 2011
Messages
154
Does the BEFORE table always have the same number of rows in every column like that sample appears to have?

BTW, you don't have the latest version of XL2BB so you may want to update to get the latest features and bug fixes.
Thank you for your help Peter.

The before table does NOT always have the same number of rows.

However, once I can achieve copying all the source columns into a single destination "A" column, I will then turn on my macro recorder to work on building the next step. The next step will be sorting all the items A-Z, then removing the duplicates.

Thanks for the XL2BB tip too!
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,502
Office Version
  1. 365
Platform
  1. Windows
So your data may actually look more like what I have in columns A:E below?

Assuming that is the only data on the worksheet then the code below produces the results shown in column G. Is that what you are after?
(Colours were just for my benefit for checking)

VBA Code:
Sub To_One_Column()
  Dim lc As Long, rws As Long, c As Long
  
  lc = Cells(1, Columns.Count).End(xlToLeft).Column
  Application.ScreenUpdating = False
  For c = 1 To lc
    rws = Cells(Rows.Count, c).End(xlUp).Row
    Cells(1, c).Resize(rws).Copy Destination:=Cells(Rows.Count, lc + 2).End(xlUp).Offset(1)
  Next c
  With Columns(lc + 2)
    .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
    .RemoveDuplicates Columns:=1, Header:=xlNo
  End With
  Application.ScreenUpdating = True
End Sub

John.McLaughlin.xlsm
ABCDEFG
1PART 1PART 6PART 10PART 17PART 18PART 1
2PART 2PART 24PART 11PART 5PART 10
3PART 21PART 3PART 3PART 20PART 11
4PART 4PART 9PART 13PART 7PART 12
5PART 5PART 4PART 22PART 13
6PART 12PART 23PART 15
7PART 16PART 15PART 16
8PART 3PART 17
9PART 18
10PART 2
11PART 20
12PART 21
13PART 22
14PART 23
15PART 24
16PART 3
17PART 4
18PART 5
19PART 6
20PART 7
21PART 9
22
Sheet1
 
Solution

John.McLaughlin

Board Regular
Joined
Jul 19, 2011
Messages
154
So your data may actually look more like what I have in columns A:E below?

Assuming that is the only data on the worksheet then the code below produces the results shown in column G. Is that what you are after?
(Colours were just for my benefit for checking)

VBA Code:
Sub To_One_Column()
  Dim lc As Long, rws As Long, c As Long
 
  lc = Cells(1, Columns.Count).End(xlToLeft).Column
  Application.ScreenUpdating = False
  For c = 1 To lc
    rws = Cells(Rows.Count, c).End(xlUp).Row
    Cells(1, c).Resize(rws).Copy Destination:=Cells(Rows.Count, lc + 2).End(xlUp).Offset(1)
  Next c
  With Columns(lc + 2)
    .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
    .RemoveDuplicates Columns:=1, Header:=xlNo
  End With
  Application.ScreenUpdating = True
End Sub

John.McLaughlin.xlsm
ABCDEFG
1PART 1PART 6PART 10PART 17PART 18PART 1
2PART 2PART 24PART 11PART 5PART 10
3PART 21PART 3PART 3PART 20PART 11
4PART 4PART 9PART 13PART 7PART 12
5PART 5PART 4PART 22PART 13
6PART 12PART 23PART 15
7PART 16PART 15PART 16
8PART 3PART 17
9PART 18
10PART 2
11PART 20
12PART 21
13PART 22
14PART 23
15PART 24
16PART 3
17PART 4
18PART 5
19PART 6
20PART 7
21PART 9
22
Sheet1

Thank you Joe!, very nice code! I think it is the foundation I need. My macro is using 2 different workbooks. I will study this code and learn how to incorporate it into my macro.

I appreciate your reply and assistance!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,587
Messages
5,637,274
Members
416,963
Latest member
samfuge

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top