data import

[steve hill]

Hi I have to import some data from an existing database to a new one. in the old system I have a table that contains a number of text fields that will need to be imported a a single field in the new one/

partnumber routeno opnumber text
PCL 6363 1 10 BOND FACEPLATE TO COWL ASSEMBLY
PCL 6363 1 10 BOND SEALING STRIP TO COWL ASSEMBLY
PCL 6363 1 10 BOND FOAM COMFORT STRIP
PCL 6363 1 10 BOND RIP OFF TOGGLE TO FACEPLATE
PCL 6363 1 30 APPLY COATS OF BROMO BUTYL SOLUTION TO THE INTERNAL SURFACE OF RIP OFF STRIP
PCL 6363 1 30 , FILLING THE SLIT.
PCL 6363 1 30 APPLY COATS OF BROMO BUTYL SOLUTION TO THE EXTERNAL SURFACE OF THE RIP OFF
PCL 6363 1 30 STRIP
PCL 6363 1 40 FIT MICROPHONE TO HOOD ASSEMBLEY
PCL 6363 1 40 FIT CABLE TIE TO SECURE MICROPHONE TO HOOD ASSEMBLEY
PCL 6363 1 50 APPLY 1 COAT OF BROMO BUTYL SOLUTION TO THE INTERNAL SURFACE OF THE RIP OFF
PCL 6363 1 50 STRIP ENSURING THE SLIT IS FULL
PCL 6363 1 50 APPLY 1 COAT OF BROMO BUTYL SOLUTION TO THE EXTERNAL SURFACE OF THE RIP OFF
PCL 6363 1 50 STRIP

As you can see I have a part number route no and op number with multi-pal text lines. I need to merge all text line with the same part number route no and op number. I have about 500 part number with a various number of op and text line.
thanks for your time

steve

 

[ParamRay]

.
.

Place the following macro in a standard code module in your workbook and, before running, amend the line indicated in the comments.

Assumptions made:
(1) Column headings are in Row 1;
(2) Columns are: (A) Part Number, (B) Route Number, (C) Op Number and (D) Text; and
(3) Column E is empty.

The macro will produce the desired output in column E.

Sub ConcatenateText()

    Dim sht As Worksheet
    Dim lrw As Long
    Dim rng As Range
    Dim cell_1 As Range
    Dim temp As String
    Dim cell_2 As Range
    
    Set sht = ThisWorkbook.Worksheets(1)    'Change as necessary
    
    With sht
        .Range("E1").Value = "full text"
        lrw = .Range("A" & .Rows.Count).End(xlUp).Row
        Set rng = Intersect(.Range("A2:A" & lrw), .UsedRange)
    End With
    
    For Each cell_1 In rng
        temp = vbNullString
        For Each cell_2 In rng
            If LCase(cell_2.Value) = LCase(cell_1.Value) Then
                If LCase(cell_2.Offset(0, 1).Value) = LCase(cell_1.Offset(0, 1).Value) Then
                    If LCase(cell_2.Offset(0, 2).Value) = LCase(cell_1.Offset(0, 2).Value) Then
                        Select Case Len(temp)
                            Case Is = 0: temp = cell_2.Offset(0, 3).Value
                            Case Else: temp = temp & "; " & cell_2.Offset(0, 3).Value
                        End Select
                    End If
                End If
            End If
        Next cell_2
        cell_1.Offset(0, 4).Value = temp
    Next cell_1
    
    sht.Range("A1").CurrentRegion.RemoveDuplicates _
        Columns:=Array(1, 2, 3, 5), _
        Header:=xlYes

End Sub

 

[steve hill]

.
.

Place the following macro in a standard code module in your workbook and, before running, amend the line indicated in the comments.

Assumptions made:
(1) Column headings are in Row 1;
(2) Columns are: (A) Part Number, (B) Route Number, (C) Op Number and (D) Text; and
(3) Column E is empty.

The macro will produce the desired output in column E.

Sub ConcatenateText()

    Dim sht As Worksheet
    Dim lrw As Long
    Dim rng As Range
    Dim cell_1 As Range
    Dim temp As String
    Dim cell_2 As Range
    
    Set sht = ThisWorkbook.Worksheets(1)    'Change as necessary
    
    With sht
        .Range("E1").Value = "full text"
        lrw = .Range("A" & .Rows.Count).End(xlUp).Row
        Set rng = Intersect(.Range("A2:A" & lrw), .UsedRange)
    End With
    
    For Each cell_1 In rng
        temp = vbNullString
        For Each cell_2 In rng
            If LCase(cell_2.Value) = LCase(cell_1.Value) Then
                If LCase(cell_2.Offset(0, 1).Value) = LCase(cell_1.Offset(0, 1).Value) Then
                    If LCase(cell_2.Offset(0, 2).Value) = LCase(cell_1.Offset(0, 2).Value) Then
                        Select Case Len(temp)
                            Case Is = 0: temp = cell_2.Offset(0, 3).Value
                            Case Else: temp = temp & "; " & cell_2.Offset(0, 3).Value
                        End Select
                    End If
                End If
            End If
        Next cell_2
        cell_1.Offset(0, 4).Value = temp
    Next cell_1
    
    sht.Range("A1").CurrentRegion.RemoveDuplicates _
        Columns:=Array(1, 2, 3, 5), _
        Header:=xlYes

End Sub

I have tried it on a small section of the data and get a complier error invalid outside procedure

thanks
steve

 

[ParamRay]

.
.

Which line returned the error?..

 

[ParamRay]

.
.

Which line returned the error?..

.
.

Sorry, ignore my last post.

Make sure you place the macro in a standard code module (i.e. not in ThisWorkbook, Sheet1 or Sheet2, etc.) and make sure to include the Sub... and End Sub statements at the beginning and end, respectively.

 

[steve hill]

.
.

Sorry, ignore my last post.

Make sure you place the macro in a standard code module (i.e. not in ThisWorkbook, Sheet1 or Sheet2, etc.) and make sure to include the Sub... and End Sub statements at the beginning and end, respectively.

thanks that worked a treat probably saved me a week of manual editing

thanks for your time its greatly appreciated

Steve

 

[ParamRay]

thanks that worked a treat probably saved me a week of manual editing

thanks for your time its greatly appreciated

Steve

No probs, glad you got it to work!