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

أخي الكريم اسكندراني حاول تدرس الكود وركز على الأسطر المطلوب شرحها لنفيدك .. استخدم مفتاح F8 أثناء تشغيل الكود لتنفيذ الكود سطر بسطر لتتعرف على كل سطر على حدا تقبل تحياتي

أخي الكريم نايف جرب الرابط التالي عله يفيدك من هنا

إخواني الكرام لم أتابع الموضوع بشكل جيد من البداية ، وبدأت من حيث انتهى الآخرون .. بدأت من مشاركة أخونا الحبيب سليم والتي أرفق فيها ملف فوجدت الحل بالكود وقد استخدم الحلقات التكرارية في حين أن الموضوع يمكن أن يكون أبسط إذا تم استخدام خاصية الـ TRANSPOSE .. ويمكن برمجتها أيضاً قم بتحديد النطاق في الصف المراد تحويله لعمود .. على سبيل المثال A7:BC7 كليك يمين ثم كوبي Copy أي نسخ اذهب للخلية المراد لصق البيانات بها ثم كليك يمين ثم اختر لصق خاص Paste Special وعلم علامة صح على الخيار TRANSPOSE ثم أوك وكل عام وأنتم بخير

أخي الكريم أبو سلمان جرب الرابط التالي علك تجد فيه ضالتك إن شاء الله الرابط من هنا

أخي الكريم عبد اللطيف جرب الرابط التالي من هنا

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

السلام عليكم أخي الكريم هشام إليك نموذج لكيفية التعامل ونسخ البيانات من ملف مغلق ، قم بدراسة الملف المرفق بشكل جيد وإن شاء الله يساعدك في إتمام طلبك ، وأعتذر لضيق الوقت لتقديم الحل على ملفاتك Sub CopyFromClosedWB(strSourceWB As String, strSourceWS As String, strSourceRange As String, rngTarget As Range) Dim WB As Workbook Application.ScreenUpdating = False Application.StatusBar = "Copying Data From " & strSourceWB & "..." On Error Resume Next Set WB = Workbooks.Open(strSourceWB, True, True) On Error GoTo 0 If Not WB Is Nothing Then On Error Resume Next With WB.Worksheets(strSourceWS).Range(strSourceRange) .Copy rngTarget End With On Error GoTo 0 WB.Close False Set WB = Nothing End If Application.StatusBar = False Application.ScreenUpdating = True End Sub Sub TestCopyFromClosedWB() CopyFromClosedWB ThisWorkbook.Path & "\TestBook.xls", "Sheet1", "B1:F10", Range("A1") End Sub تقبل تحياتي Get Data From Closed Workbook UDF Function YasserKhalil.rar

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

الحمد لله الذي بنعمته تتم الصالحات كله بفضل الله وحده أخي الكريم صلاح ، والشكر موصول لأخونا ومعلمنا القدير عادل حنفي بارك الله فيه وكل عام وأنتم بخير

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

أخي الكريم عادل زكي بارك الله فيك على كلماتك الطيبة هلا أرفقت لنا الملف الذي تقصده لأن عدد المشاركات كثيرة في الموضوع ، وحدد الجزئية المطلوب شرحها ليساعدك إخوانك الكرام كل عام وأنت بخير

بارك الله فيك أخي الحبيب أبو حنين وجزيت خيراً على هذه الحلول المتميزة إثراءً للحل وللموضوع أقدم حل آخر ضع الكود التالي في موديول عادي (دالة معرفة) Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_String As String, SN As String, RE As String Dim Kh_Split, MyArray, Arr On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", "زين ") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Arr Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next I On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function ثم ضع الكود التالي في حدث الفورم Private Sub CommandButton1_Click() Dim Sh As Worksheet, Last As Long If Me.TextBox1 = "" Then Exit Sub Set Sh = Sheets("Sheet1") With Sh Last = .Cells(Rows.Count, 10).End(xlUp).Row + 1 .Cells(Last, "G") = Kh_Names(Me.TextBox1.Text, 1) .Cells(Last, "H") = Kh_Names(Me.TextBox1.Text, 2) .Cells(Last, "I") = Kh_Names(Me.TextBox1.Text, 3) .Cells(Last, "J") = Kh_Names(Me.TextBox1.Text, 4) End With End Sub تقبل تحياتي

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

نعم أخي الكريم يمكن الترحيل من شيت لآخر بمجرد الكتابة في عمود محدد .. ولذا طلبت منك إرفاق ملف للعمل عليه وليساعدك الأخوة الكرام سيكون الكود من خلال حدث التغير في ورقة العمل حيث سيتم تحديد العمود المطلوب العمل عليه والذي على أثره تتم عملية الترحيل المطلوبة بعد تعيين كلا من ورقتي العمل : ورقة العمل المراد الترحيل منها وورقة العمل المراد الترحيل إليها أو يمكنك البحث في المنتدى ستجد مئات الموضوعات التي تتحدث عن الترحيل وستجد ملفات مرفقة توضح كيفية تنفيذ العملية .. أما إذا استصعب عليك الأمر فقم بإرفاق ملفك

وجزيت خيراً بمثل ما دعوت لنا أبا سلمان وكل عام وأنت بخير

أخي الكريم أبو سلمان يمكن ببساطة كتابة إجراء فرعي (ماكرو) جديد يتم من خلاله استدعاء بقية الإجراءات المطلوب تنفيذها تباعاً لنفترض أن لديك ماكرو باسم Test1 وآخر باسم Test2 وآخر باسم Test3 يمكن استدعاء كل إجراء باستخدام كلمة Call أو كتابة اسم الإجراء الفرعي بشكل مباشر ليصبح الماكرو الجديد بهذا الشكل Sub ExecuteAll() Call Test1 Call Test2 Call Test3 End Sub أخي الحبيب عبد السلام أعتذر إليك .. لم أرى مشاركتك إلا الآن لأنني لم أحدث الصفحة منذ وقت ليس بالقليل تقبل وافر تقديري واحترامي

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

أخي الكريم مستر أبو مرمر إليك الكود التالي عله يفي بالغرض Sub Insert_Pictures_Resize_All() Dim PicList() As Variant Dim PicFormat As String Dim Rng As Range Dim sShape As Shape Dim xColIndex As Integer Dim xRowIndex As Integer Dim lLoop As Integer On Error Resume Next PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True) xColIndex = Application.ActiveCell.Column If IsArray(PicList) Then xRowIndex = Application.ActiveCell.Row For lLoop = LBound(PicList) To UBound(PicList) Set Rng = Cells(xRowIndex, xColIndex) Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) xRowIndex = xRowIndex + 1 Next lLoop End If End Sub قم بضبط ارتفاع الصفوف وعرض العمود كما تريد .. حدد أول خلية في العمود المطلوب إدراج الصور فيه واضبط عرض العمود كما تريد ثم نفذ الكود ، سيظهر لك نافذة تختار منها المجلد الذي يحتوي الصور ثم حدد الصور المطلوب إدراجها تقبل تحياتي

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

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

ولكن تبقى مشكلة اللغة العربية مع ملفات التحويل .. توجد برامج ولكنها ليست دقيقة بنسبة 100% وحتى المواقع التي تقوم بالتحويل ليست دقيقة بما فيها الكفاية نأمل في يوم من الأيام أن يتم الاهتمام باللغة العربية في موضوع التحويل تقبلوا تحياتي

بارك الله فيك أخي الحبيب عادل حنفي اسمح لي بوضع حل آخر إثراءً للموضوع إليك دالة معرفة توضع في موديول عادي .. Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) Dim I As Long, J As Long Dim Result As String For I = 1 To LookupRange.Columns(1).Cells.Count If LookupRange.Cells(I, 1) = Lookupvalue Then For J = 1 To I - 1 If LookupRange.Cells(J, 1) = Lookupvalue Then If LookupRange.Cells(J, ColumnNumber) = LookupRange.Cells(I, ColumnNumber) Then GoTo Skip End If End If Next J Result = Result & " " & LookupRange.Cells(I, ColumnNumber) & " ، " Skip: End If Next I MultipleLookupNoRept = Trim(Left(Result, Len(Result) - 3)) End Function لاستخدام الدالة طبقاً لآخر ملف أرفقه أخونا عادل حنفي ضع المعادلة التالية في الخلية I4 ثم قم بسحبها =MultipleLookupNoRept(H4,$D$4:$E$18,2) حيث يمثل البارامتر الأول خلية البحث والثاني نطاق البحث والثالث رقم العمود في نطاق البحث تقبل تحياتي وكل عام وأنت بخير

بارك الله فيك أخي الحبيب سليم وجزيت خيراً كل عام وأنت بخير

أخي الكريم جمال الخطيب تعرف أنني أفضل طرح الطلبات في موضوعات جديدة لأن المشاركات الفرعية لا يلتفت إليها عادةً والدليل أن الطلب من 4 يونيو ونحن اليوم 20 يونيو أي مر 16 يوم بدون رد واحد على مشاركتك عموماً جرب الكود التالي عله يفي بالغرض إن شاء المولى Sub Flip_Columns() Dim Rng As Range, WorkRng As Range Dim I As Integer, J As Integer, K As Integer Dim xTitleId As String Dim Arr As Variant, xTemp As Variant On Error Resume Next xTitleId = "عكس القيم" Set WorkRng = Application.Selection Set WorkRng = Application.InputBox("المدى", xTitleId, WorkRng.Address, Type:=8) Arr = WorkRng.Formula For J = 1 To UBound(Arr, 2) K = UBound(Arr, 2) For I = 1 To UBound(Arr, 2) / 2 xTemp = Arr(J, I) Arr(J, I) = Arr(J, K) Arr(J, K) = xTemp K = K - 1 Next I Next J WorkRng.Formula = Arr End Sub تقبل تحياتي

يمكن استخدام الدالة المعرفة التالية لعكس الحروف Public Function strReverse(ByVal cell As Range) As String strReverse = VBA.strReverse(cell.Value) End Function أما بخصوص التحويل من ملفات PDF فأعتقد أن مشكلة اللغة العربية لم يتم حلها بالشكل الكامل للآن ..