حسونة حسين

مرفق ملف للترجمه بواسطه السيلينيوم
* لابد من تصطيب السيلينيوم ويمكنك تحميله من هذا الرابط
* وتحديث درايفر الكروم من هذا الرابط
 
 
Translator.xlsm

وعليكم السلام ورحمه الله وبركاته
تفضل
 
رسالة واتساب عام محدث7.xlsm

السلام عليكم ورحمه الله وبركاته
تفضل
 
راس الصفحة - كود.xlsb

تفضل اخي
 
 
INVOICE.xlsm

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

وعليكم  السلام ورحمة الله وبركاته
أكواد VBA لا تعمل على الجوال لأن الجوال لا يدعم تشغيل برامج Excel التي تحتوي على VBA

السلام عليكم ورحمة الله وبركاته وبها نبدأ 
قم بالضغط على  enable content 
كما بالصورة

 
ولو لم تحل المشكله يمكنك الاطلاع على هذا الموضوع
 

وعليكم السلام ورحمة الله وبركاته 
تفضل 
=SUBSTITUTE(B2;",";" ")  

السلام عليكم ورحمة الله وبركاته وبها نبدأ 
تفضل
 
ورقة عمل Microsoft Excel جديد.xlsx

السلام عليكم ورحمه الله وبركاته وبها نبدأ
تفضل اخي وعليك بالشرح المستفيض حتى يتم فهم مشكلتك بصورة اوضح
تصنيع.xlsb

السلام عليكم ورحمه الله وبركاته وبها نبدأ
تفضل اخي
Option Explicit Sub Search_Transfer() Dim WS As Worksheet, cel As Range, lr As Long, Temp(), I As Long, J As Long, X Set WS = ThisWorkbook.Worksheets("Sheet2") lr = WS.Cells(Rows.Count, "R").End(xlUp).Row For Each cel In WS.Range("R5:R" & lr) If cel <> "" Then X = Application.Match(cel, WS.Columns(13), 0) If Not IsError(X) Then I = I + 1 ReDim Preserve Temp(1 To 15, 1 To I) Temp(1, I) = I For J = 2 To 15 Temp(J, I) = WS.Cells(X, J).Value Next J End If End If Next cel Temp = Application.Transpose(Temp) If I > 0 Then WS.Range("V5").Resize(I, UBound(Temp, 2)).Value2 = Temp End Sub  

وعليكم السلام ورحمه الله وبركاته
تفضل
Sub Transfer_Non_Adjacent_Columns_Using_Arrays_By_Yasser_Khalil() Dim arr As Variant, i As Variant, cr As Variant, j As Long arr = Sheets("ورقة1").Range("A1").CurrentRegion.Value 'الأعمدة المطلوب الترحيل إليها cr = Array(5, 8, 11, 15, 17, 20) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(1, 2, 3, 4, 5, 6) Sheets("ورقة2").Cells(1, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) j = j + 1 Next i End Sub  

وعليكم السلام ورحمة الله وبركاته 
تفضل
 
فصل الاسماء التي تحتوي على فاصل بينهم.xlsx

وعليكم السلام
تفضل اخي
 
MKMK1.xlsm

وعليكم السلام ورحمه الله وبركاته
تفضل اخي
 
تنفيذ ماكرو بناء على قيمة خليه2.xlsb

تفضل اخي
Dim Stock_check As Boolean, Product_check As Boolean Stock_check = Application.WorksheetFunction.CountIf(fa.Range("E2:E" & Uf), ComboBox1) > 1 Product_check = Application.WorksheetFunction.CountIf(fa.Range("A4:A" & Uf), .Cells(J, 1)) > 1 If (fa.Cells(J, 4).Value) = 0 And Stock_check = True And Product_check = True Then fa.Cells(J, 4).EntireRow.Delete End If  

وعليكم السلام ورحمه الله وبركاته
تفضل اخي
 
2024.xlsm

وعليكم السلام ورحمة الله وبركاته 
تفضل جرب هذه المعادله
=COUNTIF(Sheet1!E3:E4000;"*"& B2 &"*")  

وعليكم السلام ورحمة الله وبركاته 
 
رسائل كاش.xlsx

وعليكم السلام ورحمه الله وبركاته
تفضل اخى جرب هذا التعديل
Option Explicit Private Sub CommandButton1_Click() Dim Ws As Worksheet, CEl As Range, Sheets_name As Variant, Sh, Temp() Dim Str As String, i As Long, j As Long, Lr As Long Str = Me.TextBox1.Value Sheets_name = Array("عين غزال", "الجبيهة", "الجبيهة", "أربد", "الزرقاء") i = 0 For Each Sh In Sheets_name Set Ws = ThisWorkbook.Sheets(Sh) Lr = Ws.Cells(Ws.Rows.Count, 9).End(xlUp).Row For Each CEl In Ws.Range("A2:J" & Lr) If InStr(CEl.Value, Str) > 0 Then i = i + 1 ReDim Preserve Temp(1 To 12, 1 To i) For j = 1 To 10 Temp(j, i) = Ws.Cells(CEl.Row, j).Value Next j Temp(11, i) = Ws.Name Temp(12, i) = CEl.Address End If Next CEl Next Sh If i = 0 Then MsgBox "ما تحاول البحث عنه غير موجود في الاسواق ", vbInformation + vbSystemModal, "نظام البطاقات الائتمانية - Search " TextBox1.Text = "" Else Temp = Application.Transpose(Temp) With Me.ListBox1 .ColumnCount = 12 .ColumnWidths = "96,96,96,96,140,96,96,96,96,96,96,96" .Clear .List = Temp End With End If End Sub  
جديد.xlsm

تفضل اخى
 
ارسال واتساب.xlsm

وعليكم السلام ورحمه الله وبركاته تفضل اخى
 
Private Sub TextBox2_Change() Application.OnTime Now() + TimeValue("00:00:02"), "ورقة1.test" End Sub Sub test() Dim Wb As Workbook, WbName As String, xWb As Workbook Dim ws As Worksheet, sh As Worksheet Dim X, M, N Set ws = ThisWorkbook.Worksheets("ورقة1") If TextBox2 = "" Then AutoFilterMode = False Else WbName = "2024.xlsm" WbPath = ThisWorkbook.Path & "\" & WbName For Each Wb In Workbooks If Wb.Name = WbName Then Exit For Next On Error Resume Next Set Wb = Application.Workbooks.Item(WbName) On Error GoTo 0 If Not Wb Is Nothing Then Set sh = Wb.Worksheets("الأرصدة") ws.Range("H1").AutoFilter , field:=8, Criteria1:=TextBox2.Text 1 M = Application.Match(CDbl(Date), sh.Rows(2), 0) If IsError(M) Then ' insert column to date if not found N = Application.Match("*", sh.Rows(2), 0) sh.Columns(N).Insert sh.Cells(2, N).Value = Date GoTo 1 End If X = Application.Match(Val(TextBox2), sh.Columns(M + 2), 0) If Not IsError(X) Then With sh.Cells(X, M) .Value = ws.Cells(1, "I").Value .Interior.ColorIndex = 30 .Font.ColorIndex = 20 End With Wb.Save ' Save sheet after set data End If End If End If End Sub  

وعليكم السلام ورحمه الله وبركاته
تفضل اخي لعله طلبك
 
ماكرو قبل الطباعة.xlsm

السلام عليكم ورحمه الله وبركاته
تفضل لعله طلبك
فقط النطاق المسمي Data تم تمديده  لحل مشكلتك
 
‏‏‏‏جديد 1.xlsm

السلام عليكم ورحمه الله وبركاته وبها نبدأ
جرب هذا التعديل اخى @mahmoud nasr alhasany
 
Gestion Stocks Magasin1.xlsm