ياسر خليل أبو البراء

الأخ الكريم ناجي طايل أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية وراجع التوجيهات على هذا الرابط جرب الكود التالي عله يفي بالغرض Option Explicit 'Open the Internet object Private Declare Function InternetOpen _ Lib "wininet.dll" _ Alias "InternetOpenA" _ (ByVal sAgent As String, _ ByVal lAccessType As Long, _ ByVal sProxyName As String, _ ByVal sProxyBypass As String, _ ByVal lFlags As Long) As Long 'Connect to the network Private Declare Function InternetConnect _ Lib "wininet.dll" _ Alias "InternetConnectA" _ (ByVal hInternetSession As Long, _ ByVal sServerName As String, _ ByVal nServerPort As Integer, _ ByVal sUsername As String, _ ByVal sPassword As String, _ ByVal lService As Long, _ ByVal lFlags As Long, _ ByVal lContext As Long) As Long 'Get a file using FTP Private Declare Function FtpGetFile _ Lib "wininet.dll" _ Alias "FtpGetFileA" _ (ByVal hFtpSession As Long, _ ByVal lpszRemoteFile As String, _ ByVal lpszNewFile As String, _ ByVal fFailIfExists As Boolean, _ ByVal dwFlagsAndAttributes As Long, _ ByVal dwFlags As Long, _ ByVal dwContext As Long) As Boolean 'Send a file using FTP Private Declare Function FtpPutFile _ Lib "wininet.dll" _ Alias "FtpPutFileA" _ (ByVal hFtpSession As Long, _ ByVal lpszLocalFile As String, _ ByVal lpszRemoteFile As String, _ ByVal dwFlags As Long, _ ByVal dwContext As Long) As Boolean 'Close the Internet object Private Declare Function InternetCloseHandle _ Lib "wininet.dll" _ (ByVal hInet As Long) As Integer Sub UploadFTP() 'When uploading a file, make sure you have permisson to create a file on the server. 'The size limit for a uploading a file is 4GB. Dim hostFile As String Dim INet As Long Dim INetConn As Long Dim hostFile As String Dim Password As String Dim RetVal As Long Dim ServerName As String Dim Success As Long Dim UserName As String Const ASCII_TRANSFER = 1 Const BINARY_TRANSFER = 2 ServerName = "ftp://1.1.1.1" UserName = "nagy" Password = "12345" 'مسار الملف النصي المراد رفعه localFile = "C:\My Documents\Test.Txt" 'المسار المراد رفع الملف النصي إليه hostFile = "//My Test File.txt" RetVal = False INet = InternetOpen("MyFTP Control", 1&, vbNullString, vbNullString, 0&) If INet > 0 Then INetConn = InternetConnect(INet, ServerName, 0&, UserName, Password, 1&, 0&, 0&) If INetConn > 0 Then Success = FtpPutFile(INetConn, localFile, hostFile, BINARY_TRANSFER, 0&) RetVal = InternetCloseHandle(INetConn) End If RetVal = InternetCloseHandle(INet) End If If Success <> 0 Then MsgBox ("Upload process completed") Else MsgBox "FTP File Error!" End If End Sub لا تنسى إذا أدى الكود الغرض يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي كما لا تنسى أن تضغط كلمة "أعجبني هذا" إذا أعجبك هذا بالطبع تقبل تحياتي

جرب الأكواد بهذا الشكل (رغم أن الملف يعمل عندي على أوفيس 2013 بدون مشاكل) Sub TarhilByRegion() Dim WS As Worksheet Dim Cell As Range Dim strSheet As String Dim LR As Long Set WS = Sheets("الدفتر") Application.ScreenUpdating = False For Each Cell In WS.Range("J3:J" & WS.Cells(Rows.Count, "J").End(xlUp).Row) strSheet = Cell.Value On Error GoTo 1 LR = IIf(Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row < 3, 3, Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row + 1) Cell.Offset(, -8).Copy Sheets(strSheet).Range("D" & LR).PasteSpecial xlPasteValues Cell.Offset(, -6).Resize(, 8).Copy Sheets(strSheet).Range("E" & LR).PasteSpecial xlPasteValues 1 Next Cell WS.Activate Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Sub ClearAllExceptMain() Dim SH As Worksheet For Each SH In ThisWorkbook.Worksheets If SH.Name <> "الدفتر" And SH.Name <> "كود" Then SH.Range("B3:L1000").ClearContents Next SH End Sub لا تنسى أخي الفاضل أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي ولا تنسى أن تضغط على "أعجبني هذا" .. لاحظت أن الإعجابات ليست من صاحب الموضوع نفسه إنما من أعضاء وأخوة آخرين بمجرد إطلاعهم على الموضوع فعجباً

ربما يوجد حل ولكن ليس لدي علم به .. على حد علمي أنه يجب أن تكون البيانات لها صف واحد من العناوين بدون دمج

أخي الفاضل إسلام صلاح بارك الله فيك وجزاك الله خيراً على مرورك العطر أهلا بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية تقبل تحياتي

أخي الكريم لابد للبيانات أن يكون لها صف عناوين واضح وغير مدمج للخلايا .. صف واحد فقط بدون خلايا مدمجة على الإطلاق

أخي الحبيب أبو يوسف تستخدم الإشارة -- لتحويل القيم المنطقية True و False إلى 1 و 0 ..

أخي الفاضل عبد الله شيخون وعليكم السلام ورحمة الله وبركاته كان يجب أن تنوه أن هناك ورقة عمل مخفية للتعامل معها .. عموماً قد تداركت الأمر وقمت بعمل اللازم إليك الملف المرفق بعد إضافة كود يمسح البيانات من جميع أوراق العمل ما عدا ورقة العمل "الدفتر" وورقة العمل المخفية "كود" Sub ClearAllExceptMain() Dim SH As Worksheet For Each SH In ThisWorkbook.Worksheets If SH.Name <> "الدفتر" And SH.Name <> "كود" Then SH.Range("B3:L1000").ClearContents Next SH End Sub إن شاء الله يفي بالغرض الأخ الكريم ابو يوسف المصري أحبك الله الذي أحببتني فيه .. بارك الله فيك وجزاك الله خير الجزاء وجمعنا الله في الجنة في مستقر رحمته الأخ الحبيب الغالي ابو يوسف بارك الله فيك وجزيت خيراً على تشجيعك الدائم لابنك .. تقبل الله منا ومنكم Transfer Data By Region YasserKhalil.rar

وجزيت بمثله أخي خالد يرجى تغيير اسم الظهور للغة العربية تقبل تحياتي

تفضل البرنامج كامل ولكن بعد تجربته .. فاشل جربه ربما ينفع معك ووافنا بالنتائج أمر آخر ارفق ملفك التالف لتجربة بعض البرامج عليه علنا نصل لبرنامج يستطيع حل هذا الأمر من جذوره Kernel Excel Recovery Full.rar

ألم تؤدي المشاركة رقم 4 المطلوب؟

أخي الكريم عبد الله شيخون إليك الكود التالي Sub TarhilByRegion() Dim WS As Worksheet Dim Cell As Range Dim strSheet As String Dim LR As Long Set WS = Sheets("الدفتر") Application.ScreenUpdating = False For Each Cell In WS.Range("J3:J" & WS.Cells(Rows.Count, "J").End(xlUp).Row) strSheet = Cell.Value On Error GoTo 1 LR = IIf(Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row < 3, 3, Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row + 1) Cell.Offset(, -8).Copy Sheets(strSheet).Range("D" & LR).PasteSpecial xlPasteValues Cell.Offset(, -6).Resize(, 8).Copy Sheets(strSheet).Range("E" & LR).PasteSpecial xlPasteValues 1 Next Cell WS.Activate Application.CutCopyMode = False Application.ScreenUpdating = True End Sub لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" إذا أعجبك الحل تقبل تحياتي Transfer Data By Region YasserKhalil.rar

أخي الكريم أبو يوسف حاول تقرأ أسطر الكود سطر سطر بعناية وشوف الغرض من كل سطر ستجد الموضوع بسيط وإذا لم تفهم جزئية محددة يمكنك السؤال عنها .. هكذا يكون التعلم (التعلم الذاتي .. علم نفسك بنفسك لتصل إلى ما تريد) ولا تعتمد دائماً على الحلول الجاهزة Come Easy Go Easy (يعني اللي ييجي بالسهل يروح بالسهل) .. أما المعلومة اللي تتعب فيها بتثبت في الناااااااافوخ

وعليكم السلام أخي الحبيب أحمد الرشيدي حدد هدفك واسعى إليه وإن شاء الله بالصبر والمثابرة تصل إلى ما تريد

اشرح تخيلك للفكرة .. ومفيش مستحيل مع المحاولة إن شاء الله

أخي محمد جرب الكود التالي Sub Test() Dim arrSheetToCopy, i As Long If MsgBox("نسخ أوراق العمل المحددة إلى مصنف جديد", vbYesNo, "NewCopy") = vbNo Then Exit Sub arrSheetToCopy = Array("1", "2") Application.ScreenUpdating = False With Workbooks.Add Application.DisplayAlerts = False For i = 1 To (.Sheets.Count - 1) .Sheets(.Sheets.Count).Delete Next i .Sheets(.Sheets.Count).Name = String$(20, "Z") For i = 0 To UBound(arrSheetToCopy) ThisWorkbook.Sheets(arrSheetToCopy(i)).Copy Before:=.Sheets(.Sheets.Count) Next i .Sheets(.Sheets.Count).Delete Application.DisplayAlerts = True .SaveAs ThisWorkbook.Path & "\Yasser_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss") & ".xlsm", xlOpenXMLWorkbookMacroEnabled .Close End With Application.ScreenUpdating = True End Sub

أخي الكريم أبو يوسف النجار إليك الكود التالي عله يفي بالغرض إن شاء الله Sub Tarhil() Dim WS As Worksheet, SH As Worksheet Dim Cell As Range Dim LR As Long, I As Integer Set WS = Sheets("قيد التلاميذ") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For I = 2 To 4 Sheets(I).Range("D10:AU1000").ClearContents Next I For Each Cell In WS.Range("G10:G" & WS.Cells(Rows.Count, "G").End(xlUp).Row) If Cell.Value = "1/2" Then Set SH = Sheets("ثانية 1") ElseIf Cell.Value = "2/2" Then Set SH = Sheets("ثانية 2") ElseIf Cell.Value = "1/3" Then Set SH = Sheets("ثالثة 1") ElseIf Cell.Value = "2/3" Then Set SH = Sheets("ثالثة 2") Else GoTo 1 End If LR = IIf(SH.Cells(Rows.Count, "D").End(xlUp).Row < 10, 10, SH.Cells(Rows.Count, "D").End(xlUp).Row + 1) Cell.Offset(, -3).Resize(, 44).Copy SH.Range("D" & LR).PasteSpecial xlPasteValues 1 Next Cell MsgBox "تم بحمد الله", vbInformation Application.CutCopyMode = False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub كل عام وأنت بخير Tarhil Naggar.rar

بارك الله فيك أخي الحبيب الغالي سليم عمل متميز من شخص متميز تقبل الله منا ومنكم

أخي الكريم زوهير يرجى وضع الكود بين أقواس الكود ليظهر بشكل منضبط

المشاركة رقم 4 (اشكرك يا اخي لقد وفيت بالمطلوب) المشاركة رقم 5 (حاولت استخدام التنسيق الشرطي ولم اتوصل الي حل) شكلي لسه صايم

بارك الله فيك أستاذنا الكبير / محمد صالح وجزاك الله خير الجزاء إضافة مميزة

أعتقد الموضوع مكرر أخبرتك أنه يمكنك استخدام التنسيق الشرطي

أخي الكريم أبو حنين إليك حل آخر بدالة معرفة تسهل عليك استخدام المعادلة بدلاً من معادلة الصفيف الطويلة جداً Public Function SumTime(DataRange As Range, CodeRange As Range, SectorRange As Range, StartDate As Date, EndDate As Date) Dim ArrIn, ArrOut, ArrCode, ArrSector, I As Long, J As Long, P As Long ArrIn = DataRange.Value ArrCode = CodeRange.Value ArrSector = SectorRange.Value ReDim ArrOut(1 To Application.Caller.Rows.Count, 1 To 1) For I = (UBound(ArrCode, 1) + 1) To UBound(ArrOut, 1): ArrOut(I, 1) = "": Next I For P = 1 To UBound(ArrCode, 1) If P > UBound(ArrOut, 1) Then Exit For For I = 1 To UBound(ArrIn, 1) If CStr(ArrCode(P, 1)) = CStr(ArrIn(I, 3)) Then If ArrIn(I, 2) >= StartDate And ArrIn(I, 2) <= EndDate Then For J = 1 To UBound(ArrSector, 2) If (ArrIn(I, 7) <> "") And (ArrIn(I, 7) = ArrSector(1, J)) Then ArrOut(P, 1) = ArrOut(P, 1) + ArrIn(I, 10) Exit For End If Next J End If End If Next I If ArrOut(P, 1) = 0 Then ArrOut(P, 1) = "" Next P SumTime = ArrOut End Function قم بإدراج الدالة في موديول ثم لاستخدام الدالة قم بتحديد النطاق H5:H10 اضغط F2 من لوحة المفاتيح ثم قم بإدراج المعادلة بهذا الشكل =SumTime(عام!$G$5:$P$50,$A$5:$A$10,$B$4:$G$4,$A$2,$E$2) ثم اضغط Ctrl + Shift + Enter البارامتر الأول هو نطاق البيانات من ورقة العمل "عام" البارامتر الثاني هو النطاق A5:A10 الذي يحتوي أكواد الإدارات البارامتر الثالث هو النطاق B4:G4 الذي يمثل المهام البارامتر الرابع هو تاريخ البداية البارامتر الخامس هو تاريخ النهاية لا تنسى أن تضغط كلمة "أعجبني هذا" وتحدد أفضل إجابة إذا كانت الإجابة أفضل تقبل تحياتي حركة السائقين.rar

أخي الكريم أبو حسنين لا داعي للاعتذار فكلنا ذو خطأ الحمد لله أن تم المطلوب على خير .. وطبعاً الكود ليس لي (لست من رجال المستحيل .. ولكننا على اتصال بهم ) بالنسبة لطلب الثاني سأحاول فيه إن شاء الله .. قم بإرفاق شكل النتائج المرجوة ؟ أين هو النطاق المراد إظهار النتائج فيه ؟كيف هي شكل النتائج؟

مبدع أخي الفاضل خالد الرشيدي بارك الله فيك وجعل أعمالك في ميزان حسناتك يوم القيامة تقبل الله منا ومنكم صالح الأعمال وافر تقديري واحترامي

أخي الكريم تعليموه إليك الكود التالي عله يفي بالغرض .. سيتم نسخ ورقة العمل المسماة "المشكلة" باسم " النتيجة المطلوبة" وعمل اللازم في ورقة العمل الجديدة Sub YasserKhalil() Dim Rng As Range, DN As Range, nRng As Range, Temp As Range, R As Range Dim SHT As Worksheet Dim SHP As Shape Application.DisplayAlerts = False On Error Resume Next Sheets("النتيجة المطلوبة").Delete Sheets("المشكلة").Copy After:=Sheets(Sheets.Count) Set SHT = ActiveSheet SHT.Name = "النتيجة المطلوبة" With Sheets("النتيجة المطلوبة") Set Rng = .Range("A1").Resize(.Range("A1").CurrentRegion.Rows.Count) For Each SHP In .Shapes SHP.Delete Next SHP For Each DN In Rng If Not IsEmpty(DN.Value) And Not IsEmpty(DN.Offset(, 1).Value) Then Set Temp = DN.Offset(, 2) Else Temp = IIf(IsEmpty(Temp), DN.Offset(, 2).Value, Temp & " - " & DN.Offset(, 2).Value) If nRng Is Nothing Then Set nRng = DN Else Set nRng = Union(nRng, DN) End If End If Next DN If Not nRng Is Nothing Then nRng.EntireRow.Delete With .Range("A1").CurrentRegion .BorderAround ColorIndex:=1, Weight:=xlThin .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End With Application.DisplayAlerts = True End Sub لا تنسى أن تحدد أفضل إجابة وتضغط على كلمة "أعجبني هذا" تقبل تحياتي وكل عام وأنت بخير :fff: YasserKhalil Officena.rar