פיצול טקסט בתא למספר שורות בגליון חדש

[blueTrek1982]

פיצול טקסט בתא למספר שורות בגליון חדש

שלום,

ראשית כל, אני קצת חדש בכתיבת קוד VBA. ניסיתי לחפש פתרונות בפורומים שונים, אבל לא ממש הצלחתי לפתור את הבעיה.

יש לי קובץ אקסל עם שורות מרובות של מק"טים ומיקומים (בתא בודד) להשמת רכיבים בכרטיס אלקט.
אני רוצה לייצר קובץ/גליון אקסל חדש שלוקח את המיקומים ומפריד אותם לשורות חדשות, עד לסיום הקובץ (ex.1)
הגליון החדש צריך להכיל כותרות שלעובד יהיה קל להבין את הקובץ ולנתח אותו. (ex.2).

האם זה אפשרי בכלל?

תודה רבה לעוזרים.

 

[ziv98]

צרף קובץ

ובו דוגמה למצב ההתחלתי ולמצב הסופי.
הדוגמה צריכה להיות מספיק ברורה - איך הגעת ממצב אחד לשני, ולהכיל את כל מקרי הקצה, במידה ויש כאלה.

 

[blueTrek1982]

הקבצים הם המטרה

צירפתי קבצים של מה שיש לי כרגע ושל התוצאה שאני רוצה להגיע אליה עם קוד מאקרו (שאני לא מצליח לעשות)

האשכול נועד למציאת פתרון לבעיה.

 

[ziv98]

צירוף קובץ

צירפת תמונות של מה שיש לך.
אם אתה רוצה שיעזרו לך - עזור לנו לעזור לך...
צרף קובץ אקסל.

 

[blueTrek1982]

צירפתי את הקובץ

תודה על העזרה.

 

[ziv98]

הבהרות

עמודת from זהה לעמודת to תמיד ? אם לא אז מתי הם שונים ?
הכמות - תמיד 1 ? מה יקרה אם סך הכמות בשורה המקורית לא תתאים למספר ה"חלקים" שיווצרו מה - REF ?

 

[blueTrek1982]

תשובות

1. כן, 2 העמודות זהות תמיד בשביל הכנסת המידע למערכות הפנימיות
2. שאלה טובה, לדעתי צריכה להיות בדיקה של סך השורות לפריט ספציפי ששווה לכמות בקובץ המקור (האם זה אפשרי בכלל?)

 

[ziv98]

קוד

שים לב לפסיק בסוף הפירוט בשורה השניה

Sub sub_split()

Dim refArray() As String
orig_row = 4
dest_row = 4

While Cells(orig_row, 1) <> ""
    pn = Cells(orig_row, 1)
    part = Cells(orig_row, 4)
    qty = Cells(orig_row, 2)
    Erase refArray
    refArray = split(Trim(Cells(orig_row, 3)), ",")
    sz = UBound(refArray, 1)
    If sz + 1 <> qty Then qe = "Qty Error"
    For i = 0 To sz
        Cells(dest_row, 15) = pn
        Cells(dest_row, 16) = refArray(i)
        Cells(dest_row, 17) = refArray(i)
        Cells(dest_row, 18) = part
        Cells(dest_row, 19) = 1
        Cells(dest_row, 20) = qe

        dest_row = dest_row + 1
    Next

    qe = ""
    orig_row = orig_row + 1
Wend

End Sub

 

[blueTrek1982]

תודה רבה, מספר שאלות קטנות

1. האם ניתן לבצע את הפיצול בגליון נפרד?
2. האם יש אפשרות להוסיף כותרות לטבלה?
3. האם ניתן לבחור את סוג המפריד (פסיק, קו, גרש) לפני ביצוע ההפרדה?
4. איך ניתן להוסיף ממשק HMI עבור קבצים חדשים?

 

[ziv98]

תשובות

1. כן. בכל מקום שכתוב cells המבנה צריך להיות:
Sheets("sheet name").Cells(1, 1) = 1
כאשר שם הגיליון יהיה כתוב במפורש או בשני משתנים (עדיף) שאחד יחזיק את שם גיליון המקור והשני את היעד.
2. תקליט מאקרו, ותדביק אותו בראש בקוד....
3. מצ"ב
4. תגדיר בדיוק מה אתה רוצה

 

[blueTrek1982]

תשובה

1. מעולה - עובד
2. הקלטתי מאקרו שעובד עצמאי, אבל לא הצלחתי להפעיל אותו דרך המאקרו הכללי.
הדבקתי כ-sub לפני הקוד ולא עובד, ניסיתי גם בתוך הקוד, גם לא עובד.
3. תודה
4. אני רוצה שהמשתמש יבחר את סוג המפריד, שם הגליון החדש שאליו הוא רוצה לבצע את ההפרדה (ליצור גליון במידה ולא קיים).

 

[ziv98]

תשובות

יש 2 דרכים לייצר אינטראקציה עם המשתמש:
1. דרך inputbox - קל ופשוט
2. טופס - יפה...

מצ"ב קטע קוד שמדגים הוספת גיליון (במידה ולא קיים) ומייצר בו כותרת.
בהמשך הקוד, כל התייחסות לגיליון היעד - צריכה להיות מול המשתנה sh_name.
ניתן להוסיף עוד inpubox עבור כל פרמטר לבחירה - למשל מפריד.

Sub add_sheet()

Dim sh_name As String


'add sheet
    sh_name = InputBox("sheet name ?")
    If Not (WorksheetExists(sh_name)) Then
        Sheets.Add After:=ActiveSheet
        ActiveSheet.Name = sh_name
    End If
    
'add text to sheet
    Sheets(sh_name).[A1] = "Your Text"
    
End Sub


Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
  '[URL]https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists[/URL]
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

 

[ziv98]

להבא - הוסף את הקובץ שלך עם כל הקודים, לי אין קובץ שמור כזה

 

[blueTrek1982]

מצ"ב הקוד, האם שכחתי משהו?

משום מה אני לא מצליח להפעיל את הקובץ, יש לי הודעות שגיאה

 

[ziv98]

קוד שלם

1. חילקת את הקוד למקטעים, אבל לא התייחסת בקוד הראשי למקטעים השונים. חיברתי את הקוד כולו לאחד.
2. אין סיבה שהקוד יישב בגיליון, עדיף שיהיה במודול.

Sub sub_split()
    
'add sheet
Dim sh_name As String

    sh_name = InputBox("Add sheet name ?")
    If Not (WorksheetExists(sh_name)) Then
        Sheets.Add After:=ActiveSheet
        ActiveSheet.Name = sh_name
    End If
    
'add text to sheet
    Sheets(sh_name).[A3] = "P/N"
    Sheets(sh_name).[B3] = "From"
    Sheets(sh_name).[C3] = "To"
    Sheets(sh_name).[D3] = "description"
    Sheets(sh_name).[E3] = "QTY."
    
    
 ' add Seperator
 Dim Sep_name As String

    Sep_name = InputBox("Choose Seperator ?")
    
    
  'Main
    
Dim refArray() As String
orig_row = 4
dest_row = 4


    
While Cells(orig_row, 1) <> ""
    PN = Cells(orig_row, 1)
    part = Cells(orig_row, 4)
    qty = Cells(orig_row, 2)
    Erase refArray
    refArray = Split(Trim(Cells(orig_row, 3)), Sep_name)
    sz = UBound(refArray, 1)
    If sz + 1 <> qty Then qe = "Qty Error"
    For i = 0 To sz
        Sheets(sh_name).Cells(dest_row, 1) = PN
        Sheets(sh_name).Cells(dest_row, 2) = refArray(i)
        Sheets(sh_name).Cells(dest_row, 3) = refArray(i)
        Sheets(sh_name).Cells(dest_row, 4) = part
        Sheets(sh_name).Cells(dest_row, 5) = 1
        Sheets(sh_name).Cells(dest_row, 6) = qe

        dest_row = dest_row + 1
    Next

    qe = ""
    orig_row = orig_row + 1
Wend

End Sub


Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
 
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

 

[blueTrek1982]

תודה רבה על העזרה

מה הכוונה שהקוד יהיה במודול?

 

[blueTrek1982]

הבנתי כבר את הכוונה למודול

הפיצול עובד מעולה.
תודה רבה על העזרה והקדשת הזמן לזה.