[حل شده] چیدمان چند فایل کنار هم

[rezastage]

سلام به دوستان و اساتید محترم

بنده چند فایل csv دارم تعداد 60 عدد و میخام همه این فایل ها رو در یک شیت کنار هم بچینم هر فایل من دارای 3 ستون میباشد قصد من یک کار فوری و اتوماتیک میباشد لطفا من رو راهنمایی کنید .

[iranweld]

با سلام

حداقل یک نمونه فایل ضمیمه کنید تا امکان بررسی فراهم شود

[rezastage]

با سلام به پیوست یک نمونه فایل ارسال شد

[iranweld]

در فایل پیوست بر روی باتن تعبیه شده کلیک نموده و از پنجره باز شده مسیر پوشه فایلهای csv را مشخص نمایید

Private Sub CommandButton1_Click()

Dim directory, xx, yy As String, fileName As String, sheet As Worksheet, i, z1, z2 As Integer, j As Integer

Dim fDialog

Application.ScreenUpdating = False

Application.DisplayAlerts = False

yy = ActiveWorkbook.Name

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
  
fDialog.Title = "Select Data folder"

fDialog.InitialFileName = "C:\"
 
If fDialog.Show = -1 Then

  xx = fDialog.SelectedItems(1)

directory = "" & xx & "\" & ""

fileName = Dir(directory & "*.csv")

End If

Do While fileName <> ""
      
    Workbooks.Open (directory & fileName)
        
   z1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
   ActiveSheet.Range("A2:c" & z1).Copy
       
    Windows(yy).Activate
    
    z2 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    If z2 <= 2 Then z2 = 2
    
    Range("A" & z2).Select
    
    ActiveSheet.Paste
    
    Workbooks(fileName).Close
    
    fileName = Dir()
    
Loop

Range("A1").Select

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub 

[rezastage]

در فایل پیوست بر روی باتن تعبیه شده کلیک نموده و از پنجره باز شده مسیر پوشه فایلهای csv را مشخص نمایید

Private Sub CommandButton1_Click()

Dim directory, xx, yy As String, fileName As String, sheet As Worksheet, i, z1, z2 As Integer, j As Integer

Dim fDialog

Application.ScreenUpdating = False

Application.DisplayAlerts = False

yy = ActiveWorkbook.Name

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
  
fDialog.Title = "Select Data folder"

fDialog.InitialFileName = "C:\"
 
If fDialog.Show = -1 Then

  xx = fDialog.SelectedItems(1)

directory = "" & xx & "\" & ""

fileName = Dir(directory & "*.csv")

End If

Do While fileName <> ""
      
    Workbooks.Open (directory & fileName)
        
   z1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
   ActiveSheet.Range("A2:c" & z1).Copy
       
    Windows(yy).Activate
    
    z2 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    If z2 <= 2 Then z2 = 2
    
    Range("A" & z2).Select
    
    ActiveSheet.Paste
    
    Workbooks(fileName).Close
    
    fileName = Dir()
    
Loop

Range("A1").Select

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub 

با تشکر از زحمت
شما بنده قصد کنار هم گزاشتن این فایلهارو دارم امکان این هست به جای زیر هم باز شدن کنار هم باز بشن

[iranweld]

با تشکر از زحمت
شما بنده قصد کنار هم گزاشتن این فایلهارو دارم امکان این هست به جای زیر هم باز شدن کنار هم باز بشن

این هم کپی دیتا CSV بصورت ستونی

Private Sub CommandButton1_Click()

Dim directory, xx, yy As String, fileName As String, sheet As Worksheet, i, z1, k1 As Integer, j As Integer

Dim fDialog

Application.ScreenUpdating = False

Application.DisplayAlerts = False

yy = ActiveWorkbook.Name

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
 

fDialog.Title = "Select Data folder"

fDialog.InitialFileName = "C:\"
 
If fDialog.Show = -1 Then

  xx = fDialog.SelectedItems(1)

directory = "" & xx & "\" & ""

fileName = Dir(directory & "*.csv")

End If

Do While fileName <> ""
      
    Workbooks.Open (directory & fileName)
        
   z1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
   
       
   ActiveSheet.Range("A1:c" & z1).Copy
       
    Windows(yy).Activate
    
    
    k1 = Application.WorksheetFunction.CountA(Sheet1.Range("1:1")) + 1
    
       
    Cells(1, k1).Select
    
    ActiveSheet.Paste
    
    Workbooks(fileName).Close
    
    fileName = Dir()
    
Loop

Range("A1").Select

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub