عبدالفتاح في بي اكسيل

 هذا  ليس خطا   يعلمك  بان الكائن  غير موجود 

تحتاج  الى تنشيط  اداة  calendar   من داخل  الويندوز حتى تعمل وتظهر 

تفضل 

اخي  الكريم  من اين اتت هذه  المعادلة وكيف  تم ربطها  والية العمل وما  هو اسم  الموقع  المرتبط  بها  ثم  اعطيني شكل  النتائج  في عمود  معين  الملف  عندما  افتحه  تظهر  اخطاء  في  الخلايا  لاني  غير مرتبط  بالموقع   ضع   شرح  مفصل  قد  اجد لك شيء  في  الانترنت   يساعدك 

ASD.xlsx

اخي  اين  الملف  حتى نعرف  المدى والورقة  التي  ستطبق  عليها  

عالعموم  هذا  ملف   به  كود  برمجي   بمجرد  الضغط  عليه  يتم نسخ  المدى   بنفس  عرض العمود  في  نفس  ورقة  العمل 

Sub width_col()
Sheets("sheet1").Range("A1:e50000").Copy
    With Sheets("sheet1").Range("G1")
        .PasteSpecial xlPasteColumnWidths
        .PasteSpecial xlPasteValues, , False, False
        .PasteSpecial xlPasteFormats, , False, False
    End With
    Application.CutCopyMode = False
End Sub

FORMAT WIDTH‬.xls

تفضل  اخي  لعله  المطلوب 

Book1 (1).xls

بعد  اذن  الاساتذة   هذ ا كود  ديناميكي 

Sub TransferData()

Dim a, b, i&, Dic As Object
Set Dic = CreateObject("scripting.dictionary")

a = Sheets("Sheet1").[B7].CurrentRegion
ReDim b(1 To UBound(a), 1 To 10000)

For x = 2 To UBound(a)
    If Not Dic.exists(a(x, 2)) Then
        i = i + 1
        Dic.Add a(x, 2), i
        b(1, i) = a(x, 2)
    End If

    i = Dic(a(x, 2))
    For y = 2 To UBound(b)
        If IsEmpty(b(y, i)) Then
            b(y, i) = a(x, 3)
            Exit For
        End If
    Next
Next

Sheets("Sheet2").[C8].Resize(UBound(b), UBound(b, 2)) = b

End Sub

POSTING.xls

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

تفضل لعله المطلوب 

الدوال في العمود g        

=IFERROR(INDEX(C$4:C$1000;MATCH($F5;$B$4:$B$1000;0));"")

في العمود h

=IFERROR(INDEX(D$4:D$1000;MATCH($F4;$B$4:$B$1000;0));"")

sheet.xlsx

جرب هذا  الكود  لعله المطلوب 

Sub SAVESHEETS()
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each sh In ThisWorkbook.Worksheets
    sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveWorkbook.Close False
Next
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

SAVESHEET.xlsm

هذا  كود  يمكنك  الاستعانة به  بتحديد  اسم  الشيت واسم  الملف  ومكان  الملف 

Sub convert()
ThisWorkbook.Worksheets("sheet1").Copy
ActiveWorkbook.SaveAs Filename:="C:\aaa\file.csv", FileFormat:=xlCSVWindows
End Sub

نسال  الله ان ينفعنا بعلمكم  و ان نفيد الاخرين 

ماذا  تقصد  بالارقام  المتشابهة هل مكررة ام ماذا؟  بحثث في العمود d,c  لا يوجد قيم مكررة 

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

user.xlsm

بعد اذن استاد علي  كود بطريقة اخرى  انقر  على اي قيمة من الخلايا  المحددة سيطلع  مربع  حوار اكتب  القيمة وسيتم الاضافة 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim xRtn As Variant
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("c:m")) Is Nothing Then
            If IsNumeric(Target) And Target <> "" Then
                xRtn = Application.InputBox("Insert your value please")
                If xRtn <> False And IsNumeric(xRtn) Then
                    Target.Value = Target + xRtn
                End If
            End If
        End If
    End If
End Sub

الصلاة2.xlsm

يجب ان توضح اكثر في اي خلية يتم كتابة التاريخ الجديد حتى يتم التعديل عل بقية التواريخ 

هذه محاولة  تفضل  لعله ما تريد

ملاحظة : لا تضغط  الملف مرة اخرى   الملف صغير  لا يستحق  ذلك  كما  ان التيكست بوكس  ارقامه غير منظمة   نسقه  تجنب  لاي خطا بالكود 

Private Sub listbox1_Click()
    CheckThis = False
    If ListBox1.ListIndex = -1 Then
       MsgBox "Nothing Selected!"
       Exit Sub
    End If
    For i = 1 To 18
        Me("TextBox" & i).Text = ListBox1.Column(i - 1)
    Next
    CheckThis = True
End Sub

wdad mtn(tora(v1).xlsm

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

Sub EtaEng()
Dim idnum As Variant, b As Object, i As Double
Sheet2.Activate
idnum = Left(Range("D7").Value, 4)
Set b = Sheet1.Columns("b").Find(idnum, lookat:=xlPart, LookIn:=xlValues)
If Not b Is Nothing Then
'exists
i = b.Row
Range("D10").Value = Sheet1.Cells(i, 3)
Range("D12").Value = Sheet1.Cells(i, 2)
Range("D14").Value = Sheet1.Cells(i, 4)
Range("D16").Value = Sheet1.Cells(i, 5)
Range("H10").Value = Sheet1.Cells(i, 6)
Range("H12").Value = Sheet1.Cells(i, 7)
Range("H14").Value = Sheet1.Cells(i, 8)
Range("H16").Value = Sheet1.Cells(i, 9)
Else
MsgBox "هذا الرقم غير موجود", vbExclamation
End If

End Sub

ملاحظة  : يمكنك  تغيير عدد الارقام كما تشاء من خلال هذا  السطر   وهو مصمم لاربعة ارقام  ويجب ان تكتب الارقام من اليسار الى اليمين كما ترى 

idnum = Left(Range("D7").Value, 4)

كشف_المحتاجين_2.xlsm

في محرر الاكواد  اضغط  alt+ f11  ثم  ادراج  موديل جديد  ثم  لصق 

جرب هذا  الكود

Sub abdelfatta()
   Dim Ary As Variant
   Dim r As Long, c As Long
   
   Ary = Range("A4").CurrentRegion.Value2
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         For c = 1 To UBound(Ary, 2)
            .Item(Ary(r, c)) = .Item(Ary(r, c)) + 1
         Next c
      Next r
      Range("E4").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .items))
   End With
End Sub

الاكواد شغالة معي  ملفك هو فيه مشكلة  جرب تصميم ملف  اخر 

تفضل  اخي  هذا  بالكود  ولكن ليس  سريع  لضخامة بياناتك

EURUSD1440 (1).xlsm

كود رائع  اخي  الرائد   احسن  ما فيه  يهمل الصفوف  الفارغة  

تفضل لعله  المطلوب 

Sub SaveRange()
Dim saveLocation As String
Dim rng As Range
saveLocation = "C:\Users\سبحان الله\desktop\" & Range("B2").Value & ".pdf"
Set rng = Sheets("ورقة1").Range("A1:c12")
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation, OpenAfterPublish:=True
End Sub

جدول متغيير1.xlsm

بعد  ادن استاد  ابراهيم  يتم  وضع  الكود  في حدث change لورقة  العمل   حتى  يعمل  مباشرة  من غير تشغيل  الماكرو  في كل  مرة يتم فيها  اختيار  اسم 

Private Sub Worksheet_Change(ByVal Target As Range)
i = 2
Do While 1000
x = Cells(i, 1)
If x = Range("A1") Then
Cells(i, 1).Select
Exit Do
End If
i = i + 1
Loop
End Sub

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

النقاط.xlsm

مرحبا  بك في هذا  المنتدى  ان شاء  الله  تستفيد وتفيد  غيرك 

اخي علي  مشكلتك  الاولى تم حلها  اما  الثانية  فلم افهما  البحث  عندك  ديناميكي  من خلال  الكود  ولديك  في صفحة  DATE  فوق  600 صف  يبحث  بشكل  طبيعي  وقمت بتجربته  باضافة صفوف  واشتغل  عادي   هناك  ملاحظة   لا تسمي   ورقة  البيانات باسم DATE   لانه  هذا   الاسم  يتعامل الكود  معه  على انه تاريخ  وليس اسم ورقة  عمل  لا تختار اسماء  خاصة  بالبرمجة  والا الكود  سيحدث  فيه  اخطاء       جرب الملف واعلمني 

rr.xlsm