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
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
Advertisement