Copying and splitting data between sheets

[Jumparound]

Hi, I have a need to copy data from one sheet to another but with the added complication that some of the cells need splitting into subsequent rows and the rows that are not split should skip down to the next row below the last split row. I'm finding this difficult to explain but hopefully the examples will help!

What it needs to do is:
Copy from L4 sheet1 down to last entry in column L to L4 down to end in sheet2 but split all values by semi colon, paste each into the next row in column L

Copy from n4 in sheet1 down to last entry in column N to n4 down to end in sheet2, remove any spaces, if the character length of the cell is greater than 29 characters split into next row but split at a semi colon and remove the now redundant semi colon from either the end of the list of values or the start of the new list of values.

Copy from O4 in sheet1 down to last value in column O to O4 down to end in sheet2, remove any spaces, if the character length of the cell is greater than 29 characters split into next row down but split at a semi colon and remove the now redundant semi colon from either the end of the list of values or the start of the new list of values.

Copy from D4 to K4 in sheet1 down to last values in these columns to sheet2 D4 to K4 down to end but skip to next blank row that does not have data in column L, N or O

Copy from P4 in sheet1 to end of data in P to P4 to end in sheet2 but skip to next blank row that does not have data in column L, N or O

Copy from Q4 in sheet1 to end of data in Q to Q4 to end in sheet 2, remove spaces, remove asterisks, format as text (to preserve leading zeros) but skip to next blank row that does not have data in column L, N or O

Copy from R4 to Y4 to end of data n sheet1 to R4 to Y4 to end in sheet 2 but skip to next blank row that does not have data in column L, N or O


For example sheet1:

Test material 1

1

Bucket

10

No

20140

Yes

n/a

Component 1; Component 2;Component 3

01-May

H325; H123; H234; H356; H345;H319; H456

HP4; HP6; HP7; HP8; HP11; HP13

Solid

16 03 05*

2923

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Test material 2

2

Kegs

20

No

20140

No

n/a

Component 1; Component 2;Component 3

01-May

H325; H123; H234; H356

HP4; HP6; HP7; HP8; HP11; HP13

Solid

16 03 05*

2923

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Test material 3

3

Buckets

10

No

20140

Yes

n/a

Component 1; Component 2;Component 3

01-May

H325; H123; H234; H356

HP4; HP6; HP7; HP8; HP11; HP13

Solid

16 03 05*

2811

TOXIC SOLID, ORGANIC, N.O.S.

Yes

contains paraformaldehyde

6.1

II

E

This should copy into Sheet2 like this:

Test material 1

1

Bucket

10

No

20140

Yes

n/a

Component 1

01-May

H325;H123;H234;H356;H345;H319

HP4;HP6;HP7;HP8;HP11;HP13

Solid

160305

2923

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Component 2

H456

Component 3

Test material 2

2

Kegs

20

No

20140

No

n/a

Component 1

01-May

H325;H123:H234;H356

HP4;HP6;HP7;HP8;HP11;HP13

Solid

160305

2923

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Component 2

Component 3

Test material 3

3

Buckets

10

No

20140

Yes

n/a

Component 1

01-May

H325;H123:H234;H356

HP4;HP6;HP7;HP8;HP11;HP13

Solid

160305

2811

TOXIC SOLID, ORGANIC, N.O.S.

Yes

contains paraformaldehyde

6.1

II

E

Component 2

Component 3

 

[Jumparound]

Sorry, just realised that this doesn't include column names. It should be from this:

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Test material 1

1​

Bucket

10​

No

20140​

Yes

n/a

Component 1; Component 2;Component 3

01-May​

H325; H123; H234; H356; H345;H319; H456

HP4; HP6; HP7; HP8; HP11; HP13

Solid

16 03 05*

2923​

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Test material 2

2​

Kegs

20​

No

20140​

No

n/a

Component 1; Component 2;Component 3

01-May​

H325; H123; H234; H356

HP4; HP6; HP7; HP8; HP11; HP13

Solid

16 03 05*

2923​

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Test material 3

3​

Buckets

10​

No

20140​

Yes

n/a

Component 1; Component 2;Component 3

01-May​

H325; H123; H234; H356

HP4; HP6; HP7; HP8; HP11; HP13

Solid

16 03 05*

2811​

TOXIC SOLID, ORGANIC, N.O.S.

Yes

contains paraformaldehyde

6.1​

II

E

To this:

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Test material 1

1​

Bucket

10​

No

20140​

Yes

n/a

Component 1

01-May​

H325;H123;H234;H356;H345;H319

HP4;HP6;HP7;HP8;HP11;HP13

Solid

160305​

2923​

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Component 2

H456

Component 3

Test material 2

2​

Kegs

20​

No

20140​

No

n/a

Component 1

01-May​

H325;H123:H234;H356

HP4;HP6;HP7;HP8;HP11;HP13

Solid

160305​

2923​

CORROSIVE SOLID, TOXIC, N.O.S.

Yes

contains paraformaldehyde

8 (6.1)

II

E

Component 2

Component 3

Test material 3

3​

Buckets

10​

No

20140​

Yes

n/a

Component 1

01-May​

H325;H123:H234;H356

HP4;HP6;HP7;HP8;HP11;HP13

Solid

160305​

2811​

TOXIC SOLID, ORGANIC, N.O.S.

Yes

contains paraformaldehyde

6.1​

II

E

Component 2

Component 3

 

[Jumparound]

Any ideas on this? I've found Rick's excellent code which will split and copy rather than leaving blank rows. I'm not sure though how I would modify this to only split a cell if the character length is greater than 29 characters and into the fewest number of cells and at the ; character.

Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = ", "
  Const DelimitedColumn As String = "C"
  Const TableColumns As String = "A:C"
  Const StartRow As Long = 2
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data = Split(Cells(X, DelimitedColumn), Delimiter)
    If UBound(Data) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn)) Then
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub

 

[Jumparound]

I've managed to get this all working with a combination of macros and formulas apart from one macro that I can't get right. I'm using this macro to split the data in column N (for the purposes of table above, now column K in my sheet).

Sub CopyAndSplitDataHSGood()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim cellValue As String
    Dim valuesArray() As String
    Dim i As Long
    Dim targetCell As Range
    
    ' Set references to worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Find the last row in column K of Sheet1
    lastRow = ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row
    
    ' Set the source and target ranges
    Set sourceRange = ws1.Range("K5:K" & lastRow)
    Set targetRange = ws2.Range("L2")
    
    ' Clear previous data in Sheet2
    ws2.Range("L2:L500").Clear
    
    ' Loop through each cell in the source range
    For Each cell In sourceRange
        If cell.Value <> "" Then
            ' Remove blanks
            cellValue = Replace(cell.Value, " ", "")
            
            ' Check the number of characters
            If Len(cellValue) > 29 Then
                ' Split the cell into the minimum number of cells
                Do While Len(cellValue) > 29
                    ' Find the position of the last ";" within the first 29 characters
                    i = InStrRev(Left(cellValue, 29), ";")
                    
                    ' If a ";" is found, split the cell at that position; otherwise, split at position 29
                    If i > 0 Then
                        Set targetCell = targetRange.Offset(, 0)
                        targetCell.Value = Left(cellValue, i - 1)
                        cellValue = Mid(cellValue, i + 1)
                    Else
                        targetRange.Value = Left(cellValue, 29)
                        cellValue = Mid(cellValue, 30)
                    End If
                    
                    ' Move to the next row in Sheet2
                    Set targetRange = targetRange.Offset(1, 0)
                Loop
            End If
            
            ' Copy the remaining value to the target range
            targetRange.Value = cellValue
            
            ' Move to the next row in Sheet2
            Set targetRange = targetRange.Offset(1, 0)
        End If
    Next cell
End Sub

I can't work out how to get it to align into the correct rows as per my second example. The data comes from row 5 in sheet1 so I want to keep it with the row 5 data in sheet2 then go down to the row 6 data and paste there. I have the same problem with my similar macro running on column O

Sub CopyAndSplitDataHPGood()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim cellValue As String
    Dim valuesArray() As String
    Dim i As Long
    Dim targetCell As Range

    ' Set references to worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    ' Find the last row in column L of Sheet1
    lastRow = ws1.Cells(ws1.Rows.Count, "L").End(xlUp).Row

    ' Set the source and target ranges
    Set sourceRange = ws1.Range("L5:L" & lastRow)
    Set targetRange = ws2.Range("M2")

    ' Clear previous data in Sheet2
    ws2.Range("M2:M500").Clear

    ' Loop through each cell in the source range
    For Each cell In sourceRange
        If cell.Value <> "" Then
            ' Remove blanks
            cellValue = Replace(cell.Value, " ", "")
            
            ' Replace patterns HP1 with HP01, HP2 with HP02, etc.
            For j = 1 To 9
                cellValue = Replace(cellValue, "HP" & j, "HP0" & j)
            Next j

            ' Check the number of characters
            If Len(cellValue) > 29 Then
                ' Split the cell into the minimum number of cells
                Do While Len(cellValue) > 29
                    ' Find the position of the last ";" within the first 29 characters
                    i = InStrRev(Left(cellValue, 29), ";")

                    ' If a ";" is found, split the cell at that position; otherwise, split at position 29
                    If i > 0 Then
                        Set targetCell = targetRange.Offset(, 0)
                        targetCell.Value = Left(cellValue, i - 1)
                        cellValue = Mid(cellValue, i + 1)
                    Else
                        targetRange.Value = Left(cellValue, 29)
                        cellValue = Mid(cellValue, 30)
                    End If

                    ' Move to the next row in Sheet2
                    Set targetRange = targetRange.Offset(1, 0)
                Loop
            End If

            ' Copy the remaining value to the target range
            targetRange.Value = cellValue

            ' Move to the next row in Sheet2
            Set targetRange = targetRange.Offset(1, 0)
        End If
    Next cell
End Sub