استيراد ورقة عمل إلى الملف الحالي

[زياد علي]

اخواني الاعزاء

السلام عليكم

بالمرفق ملف يقوم باستيراد ورقة من الملف الذي تريد ،،، حيث يقوم بإدراجها بشكل تلقائي ،،،

قم بالتالي :

افتح ملف TEST اولاً ومن خلاله قم بالضغط على الوجه واختيار الملف المسمى مرفق ...

لكم كل التحايا والود

TEST.rar

[يوسف عطا]

الف شكر

لو الملف فيه أكتر من ورقة كيف أحدد الورقة المطلوب نسخها للملف الهدف ؟؟

تم تعديل يوليو 10, 2009 بواسطه يوسف عطا

[ابو اسامة العينبوسي]

السلام عليكم

بهذا الكود

Sub CombineTextFiles()
    Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String
     
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
     
    sDelimiter = "|"
     
    FilesToOpen = Application.GetOpenFilename _
    (FileFilter:="Excel Files (*.xls), *.xls", _
    MultiSelect:=True, Title:="Text Files to Open")
    
    If TypeName(FilesToOpen) = "Boolean" Then
    MsgBox "No Files were selected"
    GoTo ExitHandler
    End If
    Set wkbAll = ActiveWorkbook
    x = 1
    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    xx = Application.InputBox("ادخل عدد الاوراق المراد نسخها")
    For i = 1 To xx
    wkbTemp.Sheets(i).Copy After:=wkbAll.Sheets(wkbAll.Sheets.Count)
    Next i

    wkbTemp.Close (False)
    wkbAll.Worksheets(wkbAll.Sheets.Count).Columns("A:A").TextToColumns _
    Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
        Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
        With wkbAll
            wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
            .Worksheets(x).Columns("A:A").TextToColumns _
            Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, _
            Tab:=False, Semicolon:=False, _
            Comma:=False, Space:=False, _
            Other:=True, OtherChar:=sDelimiter
        End With
        x = x + 1
    Wend
     
ExitHandler:
    Application.ScreenUpdating = True
    Set wkbAll = Nothing
    Set wkbTemp = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler

End Sub

TEST2.rar

تم تعديل يوليو 10, 2009 بواسطه ابو اسامة العينبوسي

[engineer.saleh]

عمل جميل جدا

لكن لي ملاحظة انه لايتعرف على الامتدادات الاخرى مثل xlsm,xlsx,xla

وتقبلوا مروري

[Ahmed Emannan]

اخي الغالي

جرب الملف المرفق

امل ان يكون مطلوبك

تحياتي

________________________.rar

[زياد علي]

السلام عليكم جميعاً :

اخي ابوسامة يا سلام عليك ،،، يا سلام فعلاً لمسات خبيرة ومحترفة ،،،

خويا المهندس صالح ممكن ،،، لكن محتاج تجريب

[Ahmed Emannan]

تفضل اخي

Sub OpenUp()
    Workbooks.Open ("C:\MyFolder\MyBook.xls")
End Sub

[Ahmed Emannan]

ايضا اخي الغالي لك هذا الكود يفتح الملفات من نوع

Text Document

منقول للفائدة

Sub Get_TXT_Files()
    Dim Fnum As Long
    Dim mysheet As Worksheet
    Dim basebook As Workbook
    Dim TxtFileNames As Variant
    Dim QTable As QueryTable
    Dim SaveDriveDir As String
    Dim ExistFolder As Boolean
    
    SaveDriveDir = CurDir

    ExistFolder = ChDirNet(Application.DefaultFilePath)
    If ExistFolder = False Then
        MsgBox "Error changing folder"
        Exit Sub
    End If

    TxtFileNames = Application.GetOpenFilename _
    (filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)

    If IsArray(TxtFileNames) Then

        On Error GoTo CleanUp

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        Set basebook = Workbooks.Add(xlWBATWorksheet)

        For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)

            Set mysheet = Worksheets.Add(After:=basebook. _
                                Sheets(basebook.Sheets.Count))
            On Error Resume Next
            mysheet.Name = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
                                    InStrRev(TxtFileNames(Fnum), "\", , 1))
            On Error GoTo 0

            With ActiveSheet.QueryTables.Add(Connection:= _
                        "TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 1

                .TextFileParseType = xlDelimited
         
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False

                .TextFileColumnDataTypes = Array(1, 9, 1)

              
                .Refresh BackgroundQuery:=False
            End With
        ActiveSheet.QueryTables(1).Delete
        Next Fnum

        On Error Resume Next
        Application.DisplayAlerts = False
        basebook.Worksheets(1).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

CleanUp:

        ChDirNet SaveDriveDir

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

تم تعديل يوليو 10, 2009 بواسطه DVB Software

[سالم شباني]

السلام عليكم جميعا

موضوع مميز والردود في غاية الدقة

جعل الله ذلك في ميزان حسناتكم جميعا

[خالد القدس]

السلام عليكم

فن إبداع واحتراف لا قبل لنا به

والله الواحد يشوف الأكواد الطويلة دي مثل طلاسم المشعوذين

ولكنها تؤدي مهام خارقة مثل كرامات الصالحين

وبصراحة الاكسيل بدونها طعمه مسيخ

الله يزدكم من نعيمه يا أهل الأكواد ويرفع قدركم درجات ودرجات

[Ahmed Emannan]

اخي الغالي

هذا الكود يقوم بفتح مجلد المفضلة اذا كان

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

منقول للفائدة

تحياتي

Sub GetSpecialFolder()
    Dim WshShell As Object
    Dim SpecialPath As String

    Set WshShell = CreateObject("WScript.Shell")
    SpecialPath = WshShell.SpecialFolders("Favorites")
    MsgBox SpecialPath
    Shell "explorer.exe " & SpecialPath, vbNormalFocus
End Sub

[ا بو سليمان]

ما شاء الله   على الرغم من انها تعتبر في المشارات الاولى   بالموقع

 

الا انها برايي مهمة لكثير من الاعضاء ولهذا تم التعقيب عليها   ليشاهدها  الاخرون