توزيع البيانات

[asad1391]

الاخوه الافاضل

السلام عليكم ورحمة الله وبركاته

في هذا الكود عندما اعمل توزيع البيانات الشئ معين مثل (الصنف) اذا كان اسم نوع الصنف طويل

مثل (مكيف اسبلت اربعة وعشرون وحده )لا يقبل التوزيع به ويحوله الى رقم

سؤالي : كيف اجعل الكود أو ما التغير أو الاضافة لجعله يقبل الاسم الطويل بدون الاختصر منه

ولك خالص الشكر والتقدير

الكود:

Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
Dim xWS As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(i) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

الاصناف.xlsm

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاتة

10 ساعات مضت, asad1391 said:

لا يقبل التوزيع به ويحوله الى رقم

تقصد يحول اسم الشيت الى رقم 

اعتقد ان عدد حروف اسم الشيت يجب ان لا تتجاوز 31 حرف   من ضمنها الفراغات الواضخة والمخفية  بين الكلمات وهذا من ثوابت الاكسل

10 ساعات مضت, asad1391 said:

سؤالي : كيف اجعل الكود أو ما التغير أو الاضافة لجعله يقبل الاسم الطويل بدون الاختصر منه

 

يوجد حلان

الحل الأول، والذي ربما لا تفضله كما ذكرت، هو الاختصار الرقمي. على سبيل المثال، استبدال 'أربعة وعشرون' بالرقم '24' ليصبح الوصف: 'مكيف سبليت جنرال 24 وحدة'.

"الحل الثاني: على الرغم من أن أسماء بعض الأصناف تفي بمتطلبات الحد الأقصى لعدد الأحرف، إلا أن رفض النظام لها يحدث غالبًا بسبب وجود مسافات زائدة (ظاهرة أو مخفية). لاحظنا في ملفك وجود مسافات متكررة، مثل الفراغين بين 'سبليت جنرال'. لذلك، من الضروري تضمين دالة في الكود لمعالجة النص وإزالة جميع الفراغات الزائدة قبل حفظ البيانات."

تفضل الملف، آمل أن يلبي هذا متطلباتك

الاصناف1.xlsm

لك وافر التقدير والاحترام

[عبدللرحيم]

جرب المرفق لعله المطلوب

افكار عمالقة المنتدى

جزاهم الله خيرا

OK الاصناف.xlsm