طلب انشاء ورك بوك

[إبراهيم ابوليله]

الاخوه الافاضل

لدى شيت

اريد عند كتابة

الرقم 8 فى الخليه A1

والرقم  2015 فى الخليه A2

يتم انشاء ملف جديد باسم 82015

يتم حفظ الملف بنفس امتداد الملف الحالى

.................................................................

واريد كود اخر

لفتح الملف ايضا

بناء على الخليتين

A1

A2

..............................................

[ياسر خليل أبو البراء]

أخي الحبيب إبراهيم أبو ليلة

جرب الكود التالي عله يكون المطلوب

Dim Str1 As String, Str2 As String

Sub CreateWorkbook()
    Dim WB As Workbook
    
    Set WB = Workbooks.Add
    Str1 = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
    Str2 = ThisWorkbook.Sheets("Sheet1").Range("A2").Value
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        WB.SaveAs Filename:=ThisWorkbook.Path & "\" & Str1 & Str2 & ".xlsx"
        WB.Close True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub OpenWorkbook()
    Str1 = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
    Str2 = ThisWorkbook.Sheets("Sheet1").Range("A2").Value
    
    Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Str1 & Str2 & ".xlsx"
End Sub

 

[إبراهيم ابوليله]

اخى ياسر

مشكورا على الاهتمام

بارك

الله فيك

ولكن

بصراحه الى وقف قدامى

وانا متأكد انه مش هيصعب عليك (غالى)

انى مش عايز احدد الامتداد فى الكود

الامتداد

بيجى من الملف المفتوح الى بنحدد فيه اسم الملف الى هنفتحه

 

[ياسر خليل أبو البراء]

أخي الحبيب إبراهيم

إليك الكود التالي عله يحل المشكلة (الكود طويل بعض الشيء لأنه يتعامل مع الأخطاء التي يمكن أن تحدث ..فهو تفصيلي )

Sub CreateWorkbook()
    Dim WB As Workbook
    Dim Str1 As String, Str2 As String, StrPath As String, StrExt As String
    Dim sFileName As String, sPath As String, sPathAndFileName As String
    Dim iFileFormat As Long, iReply As Long
    Dim bNeedMore As Boolean
    
    Set WB = Workbooks.Add
    Str1 = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
    Str2 = ThisWorkbook.Sheets("Sheet1").Range("A2").Value
    StrPath = ThisWorkbook.FullName
    StrExt = Right(StrPath, Len(StrPath) - InStrRev(StrPath, "."))
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
        Select Case StrExt
            Case "xls"
                iFileFormat = -4143
            Case "xlsb"
                iFileFormat = 50
            Case "xlsx"
                iFileFormat = 51
            Case "xlsm"
                iFileFormat = 52
        End Select
        
        sPath = ThisWorkbook.Path & "\"
        sFileName = Str1 & Str2 & "." & StrExt
        sPathAndFileName = sPath & sFileName
        
        If LJMFileExists(sPathAndFileName) = True Then
            iReply = MsgBox(Buttons:=vbYesNo, Title:="'Overwrite' or 'Escape' Selection", Prompt:="The File Already Exists.  Do You Want To Overwrite The File?" & vbCrLf & "Folder: " & ThisWorkbook.Path & vbCrLf & "File Name: " & Str1 & Str2 & "." & StrExt & vbCrLf & vbCrLf & "Select 'Yes' To Overwrite The File." & vbCrLf & "Select 'No'  To Do Nothing.")
            
            If iReply = vbNo Then
                MsgBox "Nothing Done Per User Request."
                GoTo MYEXIT
            End If
        End If
        
        On Error Resume Next
            WB.SaveAs FileFormat:=iFileFormat, Filename:=sPathAndFileName
            If Err.Number = 0 Then
                MsgBox "File Saved Successfully.", 64
            ElseIf Err.Number = 1004 Then
                MsgBox "Nothing Done. Destination File Is Already Open Or Is Read/Only." & vbCrLf & "Try Again After The File Is Closed." & vbCrLf & "Folder: " & sPath & vbCrLf & "File Name: " & sFileName
            Else
                MsgBox "Nothing Done. File Save Runtime Error " & Err.Number & "." & vbCrLf & "Folder: " & sPath & vbCrLf & "File Name: " & sFileName
            End If
        On Error GoTo 0
        
MYEXIT:
        'Resume Normal Error Processing
        On Error GoTo 0
        
        WB.Close SaveChanges:=False
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Set WB = Nothing
End Sub

Private Function LJMFileExists(sPathAndFullFileName As String) As Boolean
'This Returns TRUE If File Exists And FALSE If File Does Not exist
'-----------------------------------------------------------------
    Dim iError As Integer
    Dim iFileAttributes As Integer
    
    On Error Resume Next
        iFileAttributes = GetAttr(sPathAndFullFileName)
        
        'Check The Internal Error Return
        iError = Err.Number
        Select Case iError
            Case Is = 0
                iFileAttributes = iFileAttributes And vbDirectory
                If iFileAttributes = 0 Then
                    LJMFileExists = True
                Else
                    LJMFileExists = False
                End If
            Case Else
                LJMFileExists = False
        End Select
    On Error GoTo 0
End Function

تقبل تحياتي

[إبراهيم ابوليله]

بقولك ايه ياعم ياسر

خلينا فى الكود الاولانى احسن

...........................................................................

طبعا مشكورا على المحاوله

وعلى الكود الاخير

.........................................................

بالنسبه للكود الاول

ازاى يمكن

نقل بيانات من الملف الاصلى

الى الملف الذى تم فتحه

هل يمكن عمل ذلك

عن طريق الاشاره الى اسم الملف

بالاسماء الموجوده فى الخلايا

تقبل تحياتى

[ياسر خليل أبو البراء]

نعم أخي الكريم إبراهيم

يمكن الإشارة إلى اسم المصنف الجديد ...ثم اسم ورقة العمل .. ثم نطاق الخلايا المراد نقلها ..

وذلك قبل سطر الحفظ والإغلاق للمصنف المفتوح

[إبراهيم ابوليله]

طب ممكن مثال صغير

ياريس

معلش تاعبك معايا

تقبل تحياتى

[ياسر خليل أبو البراء]

تفضل أخي إبراهيم

ThisWorkbook.Sheets("Sheet1").Range("A1:A10").Copy wb.Sheets("Sheet1").Range("A1")

 

[إبراهيم ابوليله]

اخى ياسر

معلش ارجع تانى للمطلوب

هتلاقينى كنت عايز

احدد اسم الشيت

الى هيتم نقل البيانات ليه

عن طرق كتابة اسم الملف فى الخلايا

مثلا

اسم الملف هنكتبه

فى الخليه a1

وهو  H-2015

ينفع ولا ايه

 

[ياسر خليل أبو البراء]

حاول أخي الكريم إبراهيم تدرس الكود الأول وشوف أنا اتعاملت إزاي مع المتغيرات ..وإن شاء الله تضبط معاك

أعتذر لأنني مشغول جداً الآن .. بس إن شاء الله تقدر تظبطها

تقبل تحياتي

[إبراهيم ابوليله]

ماشى ياعم ياسر

انا فعلا مختش بالى

هجرب كده واكلمك

[إبراهيم ابوليله]

معلش ياعم ياسر

اصل الموضوع ده جديد عليا حبتين

فتلاقينى عايز اعرف عنه كتير

ياعنى مثلا

لو فيه زر مخصص لفتح الملف

دلوقتى الملف مفتوح

فيه زر تانى مخصص لنقل البيانات

ازاى بقى نشير فى زر نقل البيانات

الى الملف الى تم فتحه بناء على الاسم الى فى الخليه A1

[إبراهيم ابوليله]

أخى ياسر

الحمد لله

اكتشفت الطريقه

الواحد لازم يحاول علشان يفهم وينجح

على العموم

انا بردو مصر متحرمنيش من طريقتك فى عمل الكود

تقبل تحياتى

 

[إبراهيم ابوليله]

معلش ياعم ياسر

سؤال كمان

ملوش دعوه بالموضوع

لو عندك الرقم 0

عايز تدخله فى الخليه a1

10مرات

علشان يكون بالشكل ده

0000000000

عن طريق الحلقات التكراريه

ينفع ولا ايه

تقبل تحياتى

تم تعديل ديسمبر 28, 2015 بواسطه إبراهيم ابوليله

[مختار حسين محمود]

السلام عليكم أخى ابراهيم  وحشتنا و الله 

بالنسبة للطلب الأخير  أعتقد بأن ادخال 10 أصفار فى خلية يحتاج نوع من التحايل

1 - بمعادلة تعطى أرقام  الزيرو   2 - بكود يستخدم الحلقات ويعطى نص مش أرقام    3 - بتنسيق مخصص للخلية

وفى انتظار رد  أخى و أستاذى الغالى  ياسر خليل

[إبراهيم ابوليله]

 

10 ساعات مضت, مختار حسين محمود said:

السلام عليكم أخى ابراهيم  وحشتنا و الله 

بالنسبة للطلب الأخير  أعتقد بأن ادخال 10 أصفار فى خلية يحتاج نوع من التحايل

1 - بمعادلة تعطى أرقام  الزيرو   2 - بكود يستخدم الحلقات ويعطى نص مش أرقام    3 - بتنسيق مخصص للخلية

وفى انتظار رد  أخى و أستاذى الغالى  ياسر خليل

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

اخى مختار

ربنا يكرمك

اشكرك على السؤال

طبعا كلامك بالنسبه لى مظبوط

وانا شخصيا استخدمت المعادله

rept(0,10)

وقامت باداء المطلوب

ولكن اذا اردنا عدم وجود معادله بالخليه

يبقى لازم نحول الخليه الى نص

كمان استخدمت المعادله فى الحلقات التكراريه

ونفعت الطريقه والحمد لله

...........................................................................

ولكن كما قلت

فنحن فى انتظار رد اخونا الفاضل

ياسر خليل

او اى من الاخوه الافاضل الاخرين

تقبل تحياتى