algammal قام بنشر بالامس في 17:44 قام بنشر بالامس في 17:44 (معدل) السادة خبراء أوفيسنا (اكسيل) الكرام (السلام عليكم ورحمة الله وبركاته) بداية أود أن أنوه إلى أن الملف المرفق جهد خالص للأستاذ الفاضل / عبد الله بشير عبد الله في موضوع سابق بعنوان (ترحيل بيانات موظف محال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات) & (تعديل كود ترحيل بيانات موظف محال للمعاش) له مني كل الشكر والتقدير والاحترام وبعد ·شاهدت أحد فيديوهات اليوتيوب وقمت – وهذه أول مرة – بتطبيق ما فيه بما يتناسب مع ما أريده؛ وذلك بإضافة الكود المرفق في (شيت معاشات) وعن طريق (زر ترحيل البيانات) في الشيت نفسه يقوم بترحيل البيانات الموجودة في العمود (E) وفقا للمهن المدونة فيه إلى شيتات مستقلة يحمل كل شيت منها نفس اسم المهنة: (طبيب – مهندس – ضابط – محامي – عامل)؛ وهكذا الحال لو تم إضافة مهنة أخرى أو تعديل في أي بيان يتم التعديل والتحديث بطريقة أوتوماتيكية في الشيتات الناشئة. ·ولكن لاحظت أن الخلايا (J3:B3) لا يتم إدراجها في الشيتات الناشئة فقمت بإدراجها يدويا عن طريق النسخ واللصق؛ ولكن عند الضغط على زر ترحيل البيانات مرة أخرى تختفي؛ وأريدها ثابتة لا تتاثر بشيء. ·وكذلك أريد الاحتفاظ بعرض الأعمدة من B:A في كل الشيتات الناتجة مطابقة تماما لمثيلتها في شيت (معاشات)؛ حيث لاحظت أن العرض يتغير لبعض الأعمدة كما هو موضح في الملف المرفق؛ علما أن عرض الأعمدة من M:C مضبوطة. ·مع ثبات الارتفاع (20.25) في الشيت بأكمله لكل الشيتات الناتجة (طبيب – مهندس – ضابط – محامي – عامل) أو الشيتات التي ممكن أن تنشأ لاحقا نتيجة إضافة مهنة أخرى في العمود (E). ·أود ان يكون الخط (Arial) ثابتا في الخلية (E3) من (شيت معاشات)؛ بدلا من (PT Bold Heading)؛ حيث أنه كلما تم ضبطه يعود ويتغير لما كان عليه بعد الضغط على زر (ترحيل المحالين على المعاش) في شيت (DATA). ولكم مني جميعا خالص الشكر والتقدير والاحترام؛ وجزاكم الله عنا خير الجزاء. ترحيل البيانات من شيت إلى عدة شيتات مستقلة.xlsb تم تعديل بالامس في 17:47 بواسطه algammal
Foksh قام بنشر منذ 19 ساعات قام بنشر منذ 19 ساعات وعليكم السلام ورحمة الله وبركاته ،، جرب أخي هذا التعديل !! Sub ترحيل_المعاش_ق() Dim wsSource As Worksheet, wsTarget As Worksheet, wsNew As Worksheet Dim sourceData As Variant, outputData() As Variant Dim i As Long, j As Long, lastRowSource As Long, lastRowTarget As Long Dim rowsToDelete As Range, delCount As Long Dim totalCols As Long: totalCols = 13 Dim t As Double: t = Timer Dim professions As Object, profession As Variant Dim colWidths() As Double Dim lastRowAfterInsert As Long ' تخزين أبعاد الأعمدة من ورقة معاشات Set wsTarget = ThisWorkbook.Sheets("معاشات") ReDim colWidths(1 To totalCols) For i = 1 To totalCols colWidths(i) = wsTarget.Columns(i).ColumnWidth Next i Set wsSource = ThisWorkbook.Sheets("DATA") With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .StatusBar = "جاري معالجة البيانات..." End With ' تثبيت الخط في الخلية E3 With wsTarget.Range("E3") .Font.Name = "Arial" .Font.Bold = True End With lastRowSource = wsSource.Cells(wsSource.Rows.Count, "M").End(xlUp).Row If lastRowSource < 5 Then GoTo CleanUp sourceData = wsSource.Range("A5:M" & lastRowSource).Value ' إنشاء قاموس للمهن Set professions = CreateObject("Scripting.Dictionary") For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" Then profession = Trim(sourceData(i, 5)) If Not professions.Exists(profession) Then professions.Add profession, Nothing End If End If Next i ' معالجة كل مهنة For Each profession In professions.Keys ' إنشاء أو تحديد الورقة الخاصة بالمهنة On Error Resume Next Set wsNew = ThisWorkbook.Sheets(profession) On Error GoTo 0 If wsNew Is Nothing Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = profession Else ' حذف البيانات القديمة مع الحفاظ على التنسيق wsNew.Cells.ClearContents End If ' نسخ الترويسة من ورقة معاشات wsTarget.Range("B3:J3").Copy wsNew.Range("B3").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False ' نسخ البيانات الخاصة بالمهنة الحالية delCount = 0 ReDim outputData(1 To UBound(sourceData, 1), 1 To totalCols) For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" And Trim(sourceData(i, 5)) = profession Then delCount = delCount + 1 For j = 1 To totalCols If (j = 9 Or j = 12) And IsDate(sourceData(i, j)) Then outputData(delCount, j) = Format(sourceData(i, j), "yyyy/mm/dd") Else outputData(delCount, j) = sourceData(i, j) End If Next j End If Next i If delCount > 0 Then lastRowTarget = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row If lastRowTarget < 5 Then lastRowTarget = 4 Set targetRange = wsNew.Range("A" & lastRowTarget + 1).Resize(delCount, totalCols) targetRange.Value = Application.Index(outputData, Evaluate("ROW(1:" & delCount & ")"), Evaluate("COLUMN(A:M)")) ' تطبيق التنسيق With targetRange .Borders.LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders.ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ShrinkToFit = True With .Font .Name = "Arial" .FontStyle = "غامق" .Size = 12 End With End With With wsNew.Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With ' ضبط ارتفاع الصفوف wsNew.Rows("5:" & (lastRowTarget + delCount)).RowHeight = 20.25 ' ضبط عرض الأعمدة For i = 1 To totalCols wsNew.Columns(i).ColumnWidth = colWidths(i) Next i ' تطبيق التنسيق الشرطي With wsNew.Range("A5:M" & (lastRowTarget + delCount)) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش""" With .FormatConditions(1) .Font.Bold = True .Font.Color = -16776961 .Interior.Color = 16764159 .StopIfTrue = False End With End With End If Set wsNew = Nothing Next profession ' حذف الصفوف من ورقة DATA Set rowsToDelete = Nothing For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" Then If rowsToDelete Is Nothing Then Set rowsToDelete = wsSource.Rows(i + 4) Else Set rowsToDelete = Union(rowsToDelete, wsSource.Rows(i + 4)) End If End If Next i If Not rowsToDelete Is Nothing Then rowsToDelete.Delete Shift:=xlUp End If ' تحديث ورقة معاشات With wsTarget lastRowAfterInsert = .Cells(.Rows.Count, "B").End(xlUp).Row If lastRowAfterInsert >= 5 Then With .Range("A4:M" & lastRowAfterInsert) .Sort Key1:=.Columns(12), Order1:=xlAscending, _ Header:=xlYes, Orientation:=xlTopToBottom End With With .Range("A5:M" & lastRowAfterInsert) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ShrinkToFit = True With .Font .Name = "Arial" .FontStyle = "غامق" .Size = 12 End With End With With .Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With .Rows("5:" & lastRowAfterInsert).RowHeight = 20.25 With .Range("A5:M" & lastRowAfterInsert) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش""" With .FormatConditions(1) .Font.Bold = True .Font.Color = -16776961 .Interior.Color = 16764159 .StopIfTrue = False End With End With End If End With ' تحديث الصيغ With wsTarget .Columns("D").NumberFormat = "0" .Range("A5").FormulaR1C1 = "=IF(RC[1]<>"""",SUBTOTAL(3,R5C2:RC[1]),"""")" .Range("A6:A10000").FormulaR1C1 = .Range("A5").FormulaR1C1 End With عد_الذكور_والإناث_والمعاشات CleanUp: With Application .Calculation = xlCalculationAutomatic .EnableEvents = True .ScreenUpdating = True .StatusBar = False End With Debug.Print "تم الانتهاء في: " & Round(Timer - t, 2) & " ثانية" End Sub 1
algammal قام بنشر منذ 5 ساعات الكاتب قام بنشر منذ 5 ساعات أخي الكريم / Foksh السلام عليكم ورحمة الله وبركاته بداية أشكر لكم سرعة الرد؛ وأتمنى أن تدلني على الطريقة التي قمت فيها بإرسال الكود على النحو المبين أعلاه حتى أستطيع أن أتواصل معكم بنفس الطريقة وكتابة الكود الذي أقصده حتى نتوصل لتفاهم مشترك؛ وتقصير المسافة نحو الوصول للمطلوب وجزاكم الله خيرا؛ وتقبل خالص تحياتي وتقديري
Foksh قام بنشر منذ 4 ساعات قام بنشر منذ 4 ساعات اهلا اخي الكريم 🤗 الأمر بسيط بإذن الله تعالى ، في المكان الذي تكتب فيه رسالتك او موضوعك أو ردك ، يوجد زر <> هذا الزر وظيفته لكتابة الأكواد التي تود مشاركتها معنا ، جربه وستجد الموضوع بتنسيق ونمط جميلين في ردودك لاحقاً.
algammal قام بنشر منذ 2 ساعات الكاتب قام بنشر منذ 2 ساعات أخي الكريم / Foksh السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا على المعلومة الجديدة بالنسبة لي أما بخصوص الكود التالي - والذي لكم الفضل في أن يظهر بهذا الشكل - والذي أعنيه فهو موجود في ورقة2 شيت ( معاشات) وبدايته هي: Sub CopyDataToWorksheets() Dim wsData As Worksheet Dim wsNew As Worksheet Dim cell As Range Dim lastRow As Long Dim i As Long Dim sheetNames As Object Set sheetNames = CreateObject("Scripting.Dictionary") ' تعيين الورقة التي تحتوي على البيانات (اسم الورقة هو "معاشات") Set wsData = ThisWorkbook.Sheets("معاشات") Application.ScreenUpdating = False ' تعطيل تحديث الشاشة لتسريع الأداء ' حساب آخر صف غير فارغ في العمود E lastRow = wsData.Cells(wsData.Rows.Count, "E").End(xlUp).Row ' تحويل البيانات في العمود E إلى أسماء الأوراق العمل ونسخ الصفوف المناسبة For Each cell In wsData.Range("E5:E" & lastRow) ' التحقق من صحة الأحرف في اسم الورقة العمل Dim sheetName As Variant sheetName = Trim(CStr(cell.Value)) ' التحقق من صحة اسم الورقة العمل المحدثة If sheetName <> "" Then ' إضافة اسم الورقة الجديدة إلى القاموس (دون تكرار) If Not sheetNames.exists(sheetName) Then sheetNames(sheetName) = 1 End If End If Next cell ' حذف الأوراق القديمة المطابقة وإنشاء أوراق جديدة For Each wsNew In ThisWorkbook.Sheets If Not wsNew Is wsData Then If sheetNames.exists(wsNew.Name) Then ' حذف الأوراق القديمة Application.DisplayAlerts = False wsNew.Delete Application.DisplayAlerts = True End If End If Next wsNew ' إنشاء الأوراق الجديدة ونسخ البيانات المطابقة For Each sheetName In sheetNames.keys If Not SheetExists(CStr(sheetName)) Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = CStr(sheetName) wsData.Rows(4).Copy Destination:=wsNew.Rows(4) i = 5 ' تبدأ من الصف الثاني Do Until IsEmpty(wsData.Cells(i, "E")) If wsData.Cells(i, "E").Value = CStr(sheetName) Then wsData.Rows(i).Copy Destination:=wsNew.Rows(wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row + 1) End If i = i + 1 Loop ' تعديل عرض الأعمدة في الورقة الجديدة وفقًا للعرض في الورقة الأصلية wsData.Columns.AutoFit wsNew.Columns.AutoFit End If Next sheetName Application.ScreenUpdating = True ' تمكين تحديث الشاشة مرة أخرى End Sub Function SheetExists(sheetName As String) As Boolean Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.Name = sheetName Then SheetExists = True Exit Function End If Next ws SheetExists = False End Function فقط أود أن ألفت الانتباه إلى أن الكود الموجود في (Module1) يعمل بكفاءة عالية ولا أريد التعديل عليه حيث أنه مرتبط بزر (ترحيل المحالين على المعاش) في شيت (DATA) إلى شيت (معاشات)؛ وما أريده أخي الكريم هو الكود المذكور عاليه والمرتبط بزر (ترحيل البيانات) الموجود في شيت (معاشات) مع الشيتات الناتجة عنه وهي: (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل)؛ ما أريده ألخصه فيما يلي: 1= أريد ظهور الخلايا (J3:B3) بنفس تنسيقها في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) وأن تظل ثابته لا تتأثر بترحيل البيانات في المرات القادمة حي أنها تختفي كلما قمت بترحيل البيانات. 2= أريد ارتفاع الصف (20.25) في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) بأكملها من أول صف لآخر صف. 3= أريد عرض الأعمدة من (B:A) فقط في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) مطابقة لعرض الأعمدة المذكورة في شيت (معاشات)؛ حيث أن عرض الأعمدة من (M:C) مضبوطة ولا تحتاج تعديل. ملحوظة: أما بخصوص الخط في الخلية (E3) شيت (معاشات) فقد تم حله بفضل الله. هذا والله الموفق والمستعان وجزاكم الله خير الجزاء؛ وأسعدكم في الدارين: الدنيا والاخرة وتقبلوا خالص احترامي وتقديري
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.