need help in split macro (VBA)

[lynn8566]

Dear all

I have a huge amount of conference record which use to write down meeting content, like shown below (sorry I have changed the content)

Excel Workbook
	A	B	C	D	E	H	I
4	TOP	Topic	Meeting minutes	Type	responsible/contact	until	attachments & links
5	*	*	*	*	*	*	*
6	2006-09-01	1th meeting MV C221 / BCF	Building 11, 3th floor, room 2.A999	*	*	*	*
7	1	requirement sections and responsibilities	Der Stuttgarter Gemeinderat ist drauf und dran, seine massive Sparpolitik der vergangenen zwei Jahre nachhaltig zu lockern. Manfred Kanzleiter, seit vielen Jahren der SPD-Haushaltsexperte, hatte mit einem Antrag im Februar den Stein ins Rollen gebracht.	AA	ADEGruen	2006-09-182006-09-18	Requirement_sections
8	2	styling data	Doppelhaushalt fr 2012/13 gehe, so kndigte Manfred Kanzleiter an, werde die st?dtische Personalpolitik "ein zentrales Thema sein".Dieses Glasdach l?sst sich auf Knopfdruck hell oder dunkel schalten. Hell ist es fast v?llig durchsichtig und bietet auch bei kalter Witterung ein Open-Air-Erlebnis.	VA	AllRot	2006-09-222006-09-22	*
Sheet1

information in column C to E is correlative.

now we want to separate each records and responsible person to a new row.

here is an example sheet

Excel Workbook
	A	B	C	D	E	F	G
1	TOP	Topic	Meeting minutes	Type	responsible/contact	until	attachments & links
2	*	*	*	*	*	*	*
3	2006-09-01	1th meeting MV C221 / BCF	Building 11, 3th floor, room 2.A999	*	*	*	*
4	1	requirement sections and responsibilitie	Der Stuttgarter Gemeinderat ist drauf und dran, seine massive Sparpolitik der vergangenen zwei Jahre nachhaltig zu lockern.	A	ADE	2006/9/18	Requirement_sections
5	1	requirement sections and responsibilitie	Manfred Kanzleiter, seit vielen Jahren der SPD-Haushaltsexperte, hatte mit einem Antrag im Februar den Stein ins Rollen gebracht.	A	Gruen	2006/9/18	*
6	2	styling data	Doppelhaushalt fr 2012/13 gehe, so kndigte Manfred Kanzleiter an, werde die st?dtische Personalpolitik "ein zentrales Thema sein".	V	All	2006/9/22	*
7	2	styling data	Dieses Glasdach l?sst sich auf Knopfdruck hell oder dunkel schalten. Hell ist es fast v?llig durchsichtig und bietet auch bei kalter Witterung ein Open-Air-Erlebnis.	A	Rot	2006/9/22	*
Sheet2

I have try to use split macro to detect alt+enter in each column, but it is not work properly.

can some one help?

thanks a lot.

 

[lynn8566]

I think maybe the problem was because that on the column H, the first row maybe without date on it just shift line(alt+ENTER). this makes code cannot split correctly.
many thanks for you concern.

<a href="http://www.flickr.com/photos/61434127@N04/5669222997/" title="Flickr 上 lynn85662011 的 2"><img src="http://farm6.static.flickr.com/5026/5669222997_46f150480d.jpg" width="500" height="152" alt="2"></a>

 

[Krishnakumar]

The image is not clear. Any chance to post the data using Excel jeanie(mask the sensitive data)

 

[lynn8566]

Excel Workbook
	A	B	C	D	E	H	I
4	TOP	Topic	Meeting minutes	Type	responsible/contact	until	attachments & links
5	*	*	*	*	*	*	*
6	*	*	*	*	*	*	*
7	3	Storage of styling data in Smaragd	blablablablablablablablabla	AAA	EckbertEckbertRot	2006-09-112006-09-11	*
minutes

like this

 

[Krishnakumar]

Hi,

Try this one.

Sub kTest()
    Dim ka, k(), i As Long, n As Long, c As Long
    Dim x, MT255Chars As String, s As String, j As Long
    Dim cAddr()   As String, m As Long, p As Long
    
    '// User settings
    Const SourceShtName         As String = "Sheet1"
    Const SourceRange           As String = "A:I"
    Const DestShtName           As String = "Sheet2"
    Const DestRange             As String = "A1"
    '//End
    
    With Worksheets(CStr(SourceShtName))
        ka = Intersect(.UsedRange, .Range(CStr(SourceRange)))
    End With
    
    ReDim k(1 To UBound(ka, 1) * 3, 1 To UBound(ka, 2))
    
    For i = 1 To UBound(ka, 1)
        x = Split(NormalizeString(ka(i, 3)), Chr(10))
        For c = 3 To 8
            ka(i, c) = NormalizeString(ka(i, c))
        Next
        For m = 0 To UBound(x)
            n = n + 1
            For c = 1 To UBound(ka, 2)
                Select Case c
                    Case 3 To 8
                        On Error Resume Next
                        s = ""
                        s = Split(ka(i, c), Chr(10))(m)
                        On Error GoTo 0
                        If Len(s) > 255 Then
                            j = j + 1
                            ReDim Preserve cAddr(1 To j)
                            cAddr(j) = Cells(i, c).Address(0, 0)
                            MT255Chars = MT255Chars & "," & s
                        Else 'If Len(s) Then
                            k(n, c) = s
'                        Else
'                            k(n, c) = ka(i, c)
                        End If
                    Case Else
                        k(n, c) = ka(i, c)
                End Select
            Next
        Next
    Next
    If j Then MT255Chars = Mid$(MT255Chars, 2)
    If n Then
        With Worksheets(DestShtName).Range(CStr(DestRange))
            .Resize(n, UBound(k, 2)).Value = k
            If j Then
                ka = Split(MT255Chars, ",")
                For i = 1 To j
                    .Range(CStr(cAddr(i))).Value = ka(i - 1)
                Next
            End If
            On Error Resume Next
            .Parent.UsedRange.Columns(3).SpecialCells(4).EntireRow.Delete
        End With
    End If
End Sub
Private Function NormalizeString(ByVal strText As String) As String
    Dim x, i  As Long, s As String
    
    x = Split(strText, Chr(10))
    For i = 0 To UBound(x)
        'If Len(Trim$(x(i))) Then
            s = s & Chr(10) & x(i) 'Trim$(x(i))
        'End If
    Next
    If Len(s) > 1 Then NormalizeString = Mid$(s, 2)
End Function

 

[lynn8566]

Hi,

Try this one.

Sub kTest()
    Dim ka, k(), i As Long, n As Long, c As Long
    Dim x, MT255Chars As String, s As String, j As Long
    Dim cAddr()   As String, m As Long, p As Long
 
    '// User settings
    Const SourceShtName         As String = "Sheet1"
    Const SourceRange           As String = "A:I"
    Const DestShtName           As String = "Sheet2"
    Const DestRange             As String = "A1"
    '//End
 
    With Worksheets(CStr(SourceShtName))
        ka = Intersect(.UsedRange, .Range(CStr(SourceRange)))
    End With
 
    ReDim k(1 To UBound(ka, 1) * 3, 1 To UBound(ka, 2))
 
    For i = 1 To UBound(ka, 1)
        x = Split(NormalizeString(ka(i, 3)), Chr(10))
        For c = 3 To 8
            ka(i, c) = NormalizeString(ka(i, c))
        Next
        For m = 0 To UBound(x)
            n = n + 1
            For c = 1 To UBound(ka, 2)
                Select Case c
                    Case 3 To 8
                        On Error Resume Next
                        s = ""
                        s = Split(ka(i, c), Chr(10))(m)
                        On Error GoTo 0
                        If Len(s) > 255 Then
                            j = j + 1
                            ReDim Preserve cAddr(1 To j)
                            cAddr(j) = Cells(i, c).Address(0, 0)
                            MT255Chars = MT255Chars & "," & s
                        Else 'If Len(s) Then
                            k(n, c) = s
'                        Else
'                            k(n, c) = ka(i, c)
                        End If
                    Case Else
                        k(n, c) = ka(i, c)
                End Select
            Next
        Next
    Next
    If j Then MT255Chars = Mid$(MT255Chars, 2)
    If n Then
        With Worksheets(DestShtName).Range(CStr(DestRange))
            .Resize(n, UBound(k, 2)).Value = k
            If j Then
                ka = Split(MT255Chars, ",")
                For i = 1 To j
                    .Range(CStr(cAddr(i))).Value = ka(i - 1)
                Next
            End If
            On Error Resume Next
            .Parent.UsedRange.Columns(3).SpecialCells(4).EntireRow.Delete
        End With
    End If
End Sub
Private Function NormalizeString(ByVal strText As String) As String
    Dim x, i  As Long, s As String
 
    x = Split(strText, Chr(10))
    For i = 0 To UBound(x)
        'If Len(Trim$(x(i))) Then
            s = s & Chr(10) & x(i) 'Trim$(x(i))
        'End If
    Next
    If Len(s) > 1 Then NormalizeString = Mid$(s, 2)
End Function

Sorry buddy, its not work, error was "subscript out of range" debug didnt say which line was wrong. help

 

[Krishnakumar]

Hi,

It's working fine here.

In Sheet1:

Excel Workbook
	A	B	C	D	E	F	G	H	I
4	TOP	Topic	Meeting minutes	Type	responsible/contact	*	*	until	attachments & links
5	*	*	*	*	*	*	*	*	*
6	*	*	*	*	*	*	*	*	*
7	3	Storage of styling data in Smaragd	blablablablablablablablabla	AAA	EckbertEckbertRot	*	*	2006-09-112006-09-11	*
Sheet1

In Sheet2:

Excel Workbook
	A	B	C	D	E	F	G	H	I
1	TOP	Topic	Meeting minutes	Type	responsible/contact	*	*	until	attachments & links
2	3	Storage of styling data in Smaragd	blablabla	A	Eckbert	*	*	*	*
3	3	Storage of styling data in Smaragd	blablabla	A	Eckbert	*	*	11-09-2006	*
4	3	Storage of styling data in Smaragd	blablabla	A	Rot	*	*	11-09-2006	*
Sheet2

 

[lynn8566]

Ah, i have also tried the worksheet from forum, it really works.

but if the top column was not filled with * marks, if you just delete *, then run the code and it goes wrong.

 

[Krishnakumar]

Hi,

If the data starts from the 4th row from the header row,
replace

i = 1 with i = 4

HTH

 

[lynn8566]

No, sorry still goes wrong, but i get some idea, we use column D as a standard, if there are 3 character in column D was detected, and there are only 2 date in column H then we insert a "*" in the cell H(x), after that if we split it. it will give a correct feedback, i have tested.

is it possible?

 

[Krishnakumar]

Hi,

What about replacing

x = Split(NormalizeString(ka(i, 3)), Chr(10))

with

x = Split(NormalizeString(ka(i, 4)), Chr(10))