ترحيل تلقائي لملف آخر

[أبو مالك]

السلام عليكم 

لو سمحتوا إخواني الكرام وأخص بالذكر أخي الأستاذ @حسونة حسين ,,,

إذا في إمكانية عند الضغط على خلية " الرصيد H1 " وكتابة رقم "4" مثلاَ ،

الكود يرحل فعلا الي صفحه الرصيد في نفس الملف

اريد ان يتم ترحيل الرصيد الجديد "I1" إلي ملف اخر اسمه " 2024.xlsb " عند رقم "4 "

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

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

ارسلت مرفق لتوضيح الأمر ، كلمة المرور 1122

شاكر لكم حسن تعاونكم

 

 

2024.rar

[أبو مالك]

لإيضاح طلبي بشكل أدق تم التعديل على الملفات

2024.rar

[حسونة حسين]

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

 

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

 

[أبو مالك]

جزاك الله خيرا أخي الأستاذ / @حسونة حسين

تم عمل المطلوب

جعله الله بميزان حسناتك 🌹

[حسونة حسين]

الحمد لله الذي بنعمته تتم الصالحات 

تحت امرك اخي ابو مالك