گردآوری اطلاعات از چندین ورک بوک و تجمیع آنها در یک ورک بوک

    Application.ScreenUpdating = False
    Dim f, flist, fs As Object
    
    Worksheets.Add
    
 '''Getdata file by file

'این بخش همه فایلهای موجود در یک فولدر را مشخص و یکی یکی برای انجام عملیات 'گرد آوری و به تابع getdata میفرستد


    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(PathName)
    Set flist = f.Files
   
    m = 1
    For Each f In flist
        GetData f.Name, m
        m = m + 1
    Next f
''''''''''''''''''Close all workbooks else thisworkbook
For Each w In Workbooks
        If w.Name <> ThisWorkbook.Name Then
            w.Close savechanges:=False
        End If
    Next w
    
 '''''''''''''
     Cells(1, 1).Select

End Sub

''''''

'تابع زیر نام فایل را میگیرد و اطلاعات آنرا در ستون مورد نظر کپی می کند


Sub GetData(filename As String, i)
' This macro import data of a file into thisworkbook
    

    Workbooks.Open filename:=PathName & "\" & filename
    ansfile = ActiveWorkbook.Name
    
    '''''''''copy data
    Windows(ansfile).Activate

    Set Data = Sheets("Sheet1").Range("A1:A10")  

'address of data in workbook that must be collected

   Data.Copy

    Windows(AllAnswers).Activate
    
    Cells(1, i) = filename  'نام فایل را در سلول اول درج می کند
    Cells(3, i).Select          'اطلاعات از سلول سوم به بعد کپی می شود
    ActiveSheet.Paste
   
 '''''''''''''''''Copy Finished

 
Windows(ansfile).Activate
ActiveWorkbook.Close savechanges:=False         'close data file

End Sub

'''''''''''

'تابع زیر با استفاده از امکانات ویژوال نام یک فولدر را از شما می گیرد

Private Function PicFolder()
Dim lngCount As Long

    ' Open the file dialog
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show

        ' Display paths of each file selected
        For lngCount = 1 To .SelectedItems.Count
            PicFolder = .SelectedItems(lngCount)
        Next lngCount

    End With
PicFolder = PicFolder & "\"

End Function

/ 0 نظر / 335 بازدید