aynı anda 400 excel dosyasına satır ekleme

[serkancvk55]

381 adet dosyayı aşağıdaki verdiğiniz kod ile tek bir dosyaya aktardım fakat ilk satırları almamış bunun için ne yapmalıyım. acaba bütün dosyalara aynı anda satır ekleyebilirmiyim?

Saygılarımla


Option Explicit

Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String

Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)

If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If

On Error Resume Next

Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2

Application.ScreenUpdating = False

Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)

Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2

K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""

K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True

Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[muygun]

Merhaba;
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
Satırının sonundaki 2 sayısını 1 yapıp deneyin.
İyi çalışmalar.