- Katılım
- 15 Mart 2005
- Mesajlar
- 42,455
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Ekli dosyalar
-
20.8 KB Görüntüleme: 38
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Hayırlı Sabahlar Hocam,Bütün dosyalarınızda aktarılacak sayfa adı Sheet3'mü?
Birde aktarımın nasıl olmasını istiyorsunuz?
Aktarmak istediğiniz dosyaları seçmek ister misiniz? Yoksa sabit yol tanımlayıp bu yoldaki dosyalar mı işleme alınsın?
Verilerin hepsi bir dosyada bir sayfada alt alta mı aktarılsın?
Hocam hemen deneyeceğim. Dosyalarım çok. satır yeterli olmadığında taşımayı Sayfa2 ye yapması için ne yapabilirim kodlara. Tşkler.Tanımlama bölümünde "Integer" olan değişkenleri "Long" olarak tanımlayıp deneyiniz.
Merhaba Korhan Ayhan bey,Merhaba,
Aşağıdaki kodu boş bir excel kitabına uygulayın.
Kodu çalıştırdığınızda seçtiğiniz klasör altında yeni bir excel sayfası oluşturulur ve içine klasör altındaki dosyaların ilk sayfalarındaki veriler alt alta aktarılır.
Yeni excel dosyası "Dosya_gg_aa_yyyy_ss_dd_nn" ismi ile kayıt edilir. Kırmızı bölüm günün tarihi ve saatidir.
Kod: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çiniz...", 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 edebilmek 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
çok teşekkür ederim.Burada ki sayısal değer dosyanın içinde ki sayfa sırasını ifade eder.
Set S1 = K3.Sheets(1)
Siz ikinci sırada ki sayfa için 2 olarak düzenlemelisiniz.
Kayit_Seti.Open Sorgu, Baglanti, 1, 1
ADRES BİLGİLERİ TOPLU SORGULAMA SONUCU | |||||||||||||||
S.No | T.C. Kimlik No | Adres No | Ülke | İl | İlçe | Bucak | Köy | Mahalle | Cadde/Sokak | Dış Kapı No | İç Kapı No | Köy Kayıt No | Taşınma Tarihi | Beyan Tarihi | Varsa Diğer Adresleri |
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çiniz...", 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 edebilmek 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("SBF_STK_FRMRHS_ENSONSTK_DRM_GTP").Range("A" & Satır)
Satır = K2.Sheets("SBF_STK_FRMRHS_ENSONSTK_DRM_GTP").Cells(Rows.Count, 1).End(3).Row + 2
K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""
K2.Sheets("SBF_STK_FRMRHS_ENSONSTK_DRM_GTP").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