اريد ادخال جزء من اسم الملف ب input box لتفعيله

[عاطف عبد العليم محمد]

Dim FileName As String
FileName = InputBox("Type in the name of the file you want to open", "Choose file name", "transactionTable (7).xls")

Workbooks(FileName).Activate

 

لدى هذا الكود  واريد تعديله بحيث يتم ادخال فقط الرقم 7 بدلا من transactionTable (7).xls فيفعل الملف transactionTable (7).xls  او  ادخال 8 فيفعل الملف transactionTable (8).xls  وهكذا 

شكرا لكم

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

تفضل اخي يمكنك اختيار ما يناسبك 

Sub TEST1()                       
Dim arr(1 To 3) As String
' المسار الافتراضي للمصنف المفتوح
arr(1) = ThisWorkbook.path & "\"
arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name")
arr(3) = Dir(arr(1) & "transactionTable" & " (" & arr(2) & ")" & ".xls*")
If arr(3) <> "" Then
Set Clé = Workbooks.Open(arr(1) & arr(3))
Else
MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal
End If
End Sub
'**************
' تنشيط ورقة عمل على نفس المصنف
Sub test2()
Dim shname As String, x_Name As String
Do Until WorksheetExists(x_Name)
shname = InputBox("Type in the name of the Sheet you want to Activate")
x_Name = "transactionTable" & " (" & shname & ")"
If Not WorksheetExists(x_Name) Then MsgBox x_Name & " Doesn't exist!", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal: Exit Sub
Loop
Sheets(x_Name).Activate
End Sub
Function WorksheetExists(WSName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Worksheets(WSName).Name = WSName
    On Error GoTo 0
End Function
'******************
Sub test3()
    Dim arr(1 To 3) As String, file_name As String
        ' قم بتحديد المسار الخاص بك
    arr(1) = "C:\Users\hicham\OneDrive\Bureau\test"
    arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name")
    file_name = "transactionTable" & " (" & arr(2) & ")"
    arr(3) = arr(1) & "\" & file_name & ".xls"
    If Dir(arr(3)) = "" Then
      MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal
      Exit Sub
  End If
Workbooks.Open filename:=arr(3)
End Sub
'**************************بطرق اخرى *********************
Sub test4()
Dim arr(1 To 2) As String, WS As Workbook
arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name")
arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls"
   If Not Dir(arr(2), vbDirectory) = vbNullString Then
        Set WS = Workbooks.Open(arr(2))
    Else
MsgBox arr(2) & Chr(10) & "Workbook Not Found", 48, "Not Found"
    End If
End Sub
'*****************
Sub test5()
Dim arr(1 To 2) As String, WS As Workbook
arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name")
arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls"
    If Dir(arr(2)) = "" Then
      MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal
      Exit Sub
  End If
Set WS = Workbooks.Open(arr(2))
End Sub

 

 

 

test.rar

تم تعديل يناير 12 بواسطه محمد هشام.
ادخال جزء من اسم الملف

[عاطف عبد العليم محمد]

اخي هشام  جزاك الله خيرا

الملف المراد فتحه بيكون في التنزيلات  انا بنزله من البنك ولذلك ينزل بنفس الاسم ولكن يزيد 1

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

شكرا لك على تعبك وردك

  

تم تعديل يناير 14 بواسطه عاطف عبد العليم محمد

[عاطف عبد العليم محمد]

ملاحظة 

الملف  وليكن transactionTable (7).xls بيكون مفتوح فعلا

وانا من ملف آخر ( وليكن b2024 ) بنفذ ماكرو ينسخ من  transactionTable (7).xls ويلصق في (  b2024 )

[محمد هشام.]

 

1) أخي هذا موضوع  لا علاقة له بالسؤال المرفق في اول مشاركة. 

2) حاول إرفاق نسخة من  الملفين معا مع تحديد طريقة النسخ المتوقعة. والنطاق المطلوب ترحيله .وان شاء الله سوف نحاول مساعدتك. 

 

تم تعديل يناير 15 بواسطه محمد هشام.

[محمد هشام.]

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

Sub Copy_My_Data()
Dim Cpt&, lCol&, lRow&
Dim WSdata As Worksheet, Dest As Worksheet, MyRng As Range, r As String
Dim WS1 As Workbook, WS2 As Workbook   :Set WS1 = ThisWorkbook

 With Application
    .ScreenUpdating = False
    
r = InputBox("قم  بإدخال اسم المصنف المرغوب جلب البيانات منه", "Choose file name")
On Error Resume Next
If r = False And r <> 0 Then Exit Sub
    If r = 0 Then
 Set WS2 = Workbooks("transactionTable.xls") 'اول نسخة من المصنف = 0
    Else
 Set WS2 = Workbooks("transactionTable" & " (" & r & ")" & ".xls") ' تعريف المصنف من خلال الرقم
End If
If Not WS2 Is Nothing Then

Set WSdata = WS2.Sheets("Sheet1") ' transactionTable اسم الشيت المنسوخ منه

lRow = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
' قم بتعديل النطاق المنسوخ بما يناسبك
Set MyRng = WSdata. _
    Range("A2", WSdata.Cells(lRow, lCol))

 Set Dest = WS1.Sheets("Sheet1")  ' b2024' اسم شيت اللصق على ملف
     Cpt = Dest.Cells(Dest.Rows.Count, "A").End(xlUp).Offset(1).Row

MyRng.Copy
  Dest.Range("A" & Cpt).PasteSpecial Paste:=xlPasteValues
             Application.Goto Dest.[A1], True
             .CutCopyMode = False
             .ScreenUpdating = True
             
     MsgBox _
 "تم نسخ البيانات بنجاح من" & Chr(10) & Chr(10) & WS2.Name, vbInformation
  
  Else
MsgBox (" لم يتم العثور على المصنف ") & r, 48, "خطأ"

    On Error GoTo 0
        End If
    End With
End Sub

 بالتوفيق......

 

 

test 2.rar

تم تعديل يناير 15 بواسطه محمد هشام.
شرح بعض النقط المهمة داخل الكود

[عاطف عبد العليم محمد]

اخي محمد هشام.

جزاك الله الف خير

بعتذر لك ظننت ان وصفي للمشكلة من البداية كان كاف

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

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

والاجابة الاخيرة منكم  اخذت منها ما يفيد حل المشكلة

بارك الله فيكم و شكرا لكم