نقل البيانات الى ملف واحد

[black-eagle]

السلام عليكم

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

كيف استطيع دمج جميع الاعمدة الاولى  في ملف واحد ؟

مع الشكر

[الـعيدروس]

Public Sub Ali_Copy()
    Dim F, Fn, Nm, wb As Workbook
    Dim Dir_w, Chk$
    '**********************************
    ' مسار مجلد ملفات الإكسل
    Dir_w = "C:\Users\gh\Desktop\delet"
    '**********************************
    Th = ThisWorkbook.Name
    C = 1
    Set F = CreateObject("Scripting.FileSystemObject")
    Set Fn = F.GetFolder(Dir_w)
    For Each Fn In Fn.Files
    If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xls" Then
    Chk = Dir_w & Application.PathSeparator & Fn.Name
    If Wr_open(Chk) = False Then
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
       Workbooks.Open Chk
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    On Error GoTo 0
    End If
    End If
    Next Fn
    For wr = 1 To Workbooks.Count
     If Workbooks(wr).Name <> Th Then
        Workbooks(wr).Worksheets(1).Range("A2:A100").Copy
        Workbooks(Th).Activate
        Cells(1, C) = Workbooks(wr).Name
       Cells(2, C).PasteSpecial xlPasteValues
       C = C + 1
     End If
    Next
End Sub
Function Wr_open(Wn As String) As Boolean
Dim Wbook As Workbook
On Error Resume Next
 Set Wbook = Workbooks(Wn)
 Wr_open = Not Wbook Is Nothing
On Error GoTo 0
End Function

[black-eagle]

شكرا لك أخي الكريم

بالنسبة لرابط المجلد فهو لا يعمل

عندما اعطي Run و لكي يعمل الكود يجب أن تكون كافة الملفات مفتوحة 

[الـعيدروس]

عدل المسار الذي في الكود

Dir_w = "C:\Users\gh\Desktop\delet"

الى مسار ملفات الاكسل بمعنى تكون في مجلد واحد 

 

شاهد الشرح في المرفق لمعرفة مسار المجلد

 

 

شرح.rar

[black-eagle]

عدل المسار الذي في الكود

Dir_w = "C:\Users\gh\Desktop\delet"

الى مسار ملفات الاكسل بمعنى تكون في مجلد واحد 

 

شاهد الشرح في المرفق لمعرفة مسار المجلد

 

بارك الله أستاذ عباد

ظننت أن الكود يعمل حتى لو كانت الملفات المطلوبة مغلقة

هذا ما قصدته بكلامي .... " رابط المجلد لا يعمل "

أما الكود فهو يعمل بشكل رائع ..... 

بارك الله بك

B1.rar

[الـعيدروس]

اذهب الى السطر التالي من الكود

If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xls" Then

واستبدله بهذا

If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xlsx" Then

حسب الصورة المرفقه لديك امتداد الملفات هيا "xlsx"

 

تحياتي

[black-eagle]

اذهب الى السطر التالي من الكود

If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xls" Then

واستبدله بهذا

If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xlsx" Then

حسب الصورة المرفقه لديك امتداد الملفات هيا "xlsx"

 

تحياتي

الان تفعل الرابط

شكرا على المجهود الرائع

بارك الله بك