Delim problem?

QuestionEdit

How was your New Year start? I hope You are fine and still giving precious instructions as usual for those who get trapped with Excel.

I would like to consult with You on a matter that bothers me. Some time ago I found a macro (I) (and added necessary changes to it) that splits data to separate sheets to the same book based on column C where I have case IDs with other info in the row.

One case can have several rows depending on the number of measurements belonging to it. So it means, that I have the same ID in column C repeated when measurement is more than one.

This works fine and as a result I have the original sheet with extra sheets named by the ID from column C and each contains the rows that belongs to that ID number.

Then I have another macro (II) (I committed it) which creates and savesdocument sheet by sheet (that has ID in the sheet name).

Here I experience some strange output. Namely, when I check each finisheddocument, if measurement was more than 1 for one ID on the xls sheet, it picks up measurements from unrelated other sheets as well. So, I have accumulated measurement list from unrelated several sheets in almost eachdocument (not when measurement is only one).

I attach the problematic part of the macro because the whole is too long and I would not like to waste your time on it. This part is related to the copy from one book (bk temp.xls; M2 to down) to the other book (bk1 esanko.xls) M16 with transpose=true.

What I do then is basically merge measurement names to one cell when I have more than one right to M16 (that is N16 <>¡±¡±). It just seems to me that the variable in concern does forget to ¡°empty¡± itself when jumps to the next sheet so I almost always have all measurement names in all doc files.

I hope could explain my problem well, but please tell me if I missed/messed up something.

Do You have any idea how this can be solved? I would really appreciate your kind help.

Best attis

Macro (I) Sub test()

   Dim sh As Worksheet
   Dim rng As Range
   Dim C As Range
   Dim List As New Collection
   Dim Item As Variant
   Dim ShNew As Worksheet
   Dim FName As String
   Dim j As Integer
   
   Application.ScreenUpdating = False
   Set sh = Worksheets("Sheet1")
   Set rng = sh.Range("C2:C" & sh.Range("C65536").End(xlUp).Row)
   On Error Resume Next
   For Each C In rng
       List.add C.Value, CStr(C.Value)
   Next C
   On Error GoTo 0
   Set rng = sh.Range("C1:C" & sh.Range("C65536").End(xlUp).Row)
   For Each Item In List
       Set ShNew = Worksheets.add
       ShNew.Name = Item
       rng.AutoFilter Field:=1, Criteria1:=Item
       sh.Cells.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
       ShNew.Copy
       FName = ThisWorkbook.Path & "\" & Item & ".csv"
       ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlCSV
       ActiveWorkbook.Close SaveChanges:=False
       rng.AutoFilter
   Next Item
   sh.Activate
   On Error Resume Next
   Kill "C:\Documents and Settings\attis\Application Data\Microsoft\Excel\XLSTART\*.csv*"
   On Error GoTo 0

End Sub

Macro (II) Sub tenkan()

Dim bk As Workbook Dim bk1 As Workbook Dim bk2 As Workbook Dim bk3 As Workbook Dim sh As Worksheet 'Dim i As Integer Dim Temp_row As Integer Dim rng As Range Dim sh2 As Worksheet Dim cell As Range, r As Range, r1 As Range Dim res As Variant Dim C As Range Dim rw As Long, i As Long, j As Long Dim numcolumns As Long Dim PF As Workbook Dim strFilename, strDirname, strPathname, strDefpath As String

sPath = "C:\Documents and Settings\attis\My Documents\MACRO\"

   On Error Resume Next
   Set bk = Workbooks("temp.xls")
   On Error GoTo 0
   If bk Is Nothing Then
   Set bk = Workbooks.Open(sPath & "temp.xls")
   End If

bk.Activate Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True

Sheets(1).Select

For Each sh In Worksheets

   Workbooks.Open (sPath & "esanko.xls")
   Set bk1 = Workbooks("esanko.xls")

bk.Activate

Range("M2").Select Set rng = Range("M2:M" & Range("M65536").End(xlUp).Row) rng.Copy

bk1.Activate Sheets("JMAB").Select Range("M16").Select

   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
       False, Transpose:=True

Range("M16").Select Range(Selection, Selection.End(xlToRight)).Select Const sDELIM As String = "、"

       Dim rCell As Range
       Dim sMergeStr As String
       With Selection
           If Range("N16") <> "" Then
           For Each rCell In .Cells
               sMergeStr = sMergeStr & sDELIM & rCell.Text
           Next rCell
           Application.DisplayAlerts = False
           .Merge Across:=False
           Application.DisplayAlerts = True
           .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM))
           End If
       End With

¡­.. ¡®it continues with other staff but I picked up the problematic part only.

End Sub

AnswerEdit

attis,

Yes, you never clear your sMergeStr. I added a line to do that.

Range("M16").Select Range(Selection, Selection.End(xlToRight)).Select Const sDELIM As String = "、"

      Dim rCell As Range
      Dim sMergeStr As String
      With Selection
          If Range("N16") <> "" Then
           sMergeStr = ""    ' < = line added to clear sMergeStr
          For Each rCell In .Cells
              sMergeStr = sMergeStr & sDELIM & rCell.Text
          Next rCell
          Application.DisplayAlerts = False
          .Merge Across:=False
          Application.DisplayAlerts = True
          .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM))
          End If
      End With