اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by محمد هشام.,

الردود الموصى بها

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

تم تعديل بواسطه محمد هشام.
ادخال جزء من اسم الملف
  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

  

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

 

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

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

 

تم تعديل بواسطه محمد هشام.
رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

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

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

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

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

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

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

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information