+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı (/konu-klasor-icerisindeki-3-yardimci-kitaptan-ana-kitaba-veri-aktarimi.html)
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 07/05/2021
Çok teşekkür ederim. İyi geceler iyi sahurlar emek verdiniz hakkınızı ödeyemeyiz.
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 07/05/2021
(07/05/2021, 02:13)yyhy yazdı: Çok teşekkür ederim. İyi geceler iyi sahurlar emek verdiniz hakkınızı ödeyemeyiz.Rica ederim abey,sizede hayırlı sahurlar.Hakkım tüm üyelere Helaldir
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 07/05/2021
Konya'dan selam saygı ve dua ile...
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
Alttaki gibide kullanabilirsiniz abey.
Sayfa askları ile başlıyorsa eklendi ve currentregion yerine tüm hücreler kopyanandırıldı.
Sub GetData()
Dim sFile As Workbook, tFile As Workbook
Dim dosya As String, kes, parcaAl
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("Senelik Mazeret")
Set s2 = tFile.Sheets("Dr.Raporlu Sevk")
Set s3 = tFile.Sheets("Ücretsiz")
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls*")
s1.Cells.ClearContents: s2.Cells.ClearContents: s3.Cells.Clear
Do While dosya <> ""
If dosya <> ThisWorkbook.Name Then
Set sFile = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dosya)
kes = Split(dosya, ".")
parcaAl = Mid(dosya, 1, Len(dosya) - Len(kes(UBound(kes))) - 1)
If parcaAl Like "Liste1(Senelik Mazeret)*" Then
sFile.Worksheets("Sayfa1").Cells.Copy s1.Cells(1, 1)
ElseIf parcaAl Like "Liste2(Dr.Raporlu Sevk)*" Then
sFile.Worksheets("Sayfa1").Cells.Copy s2.Cells(1, 1)
ElseIf parcaAl Like "Liste3(Ücretsiz)*" Then
sFile.Worksheets("Sayfa1").Cells.Copy s3.Cells(1, 1)
End If
kes = "": sFile.Close
End If
Application.CutCopyMode = False
dosya = Dir
Loop
Application.ScreenUpdating = True
s1.Activate
s1.Cells(1, 1).Activate
MsgBox "Bitti"
Set sFile = Nothing: Set tFile = Nothing: parcaAl = vbNullString
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
Yada sayfadaki sütunlar sabitse alttakide olabilir.
Daha fazla Excel dosyası varsa function ile kısatlılabilir.
ya bunu kullanın yada önceki mesajdakini bence.
currentregion olayı biraz garip ben kullanmıyorum lakin izlediğim videolarda bunu kullanıyorlar kod kısa olsun diye.
Sub GetData()
Dim sFile As Workbook, tFile As Workbook
Dim dosya As String, kes, parcaAl, son As Long
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("Senelik Mazeret")
Set s2 = tFile.Sheets("Dr.Raporlu Sevk")
Set s3 = tFile.Sheets("Ücretsiz")
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls*")
s1.Cells.ClearContents: s2.Cells.ClearContents: s3.Cells.Clear
Do While dosya <> ""
If dosya <> ThisWorkbook.Name Then
Set sFile = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dosya)
kes = Split(dosya, ".")
parcaAl = Mid(dosya, 1, Len(dosya) - Len(kes(UBound(kes))) - 1)
If parcaAl Like "Liste1(Senelik Mazeret)*" Then
son = sFile.Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
sFile.Worksheets("Sayfa1").Range("A1:E" & son).Copy s1.Cells(1, 1)
ElseIf parcaAl Like "Liste2(Dr.Raporlu Sevk)*" Then
son = sFile.Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
sFile.Worksheets("Sayfa1").Range("A1:AA" & son).Copy s2.Cells(1, 1)
ElseIf parcaAl Like "Liste3(Ücretsiz)*" Then
son = sFile.Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
sFile.Worksheets("Sayfa1").Range("A1:K" & son).Copy s3.Cells(1, 1)
End If
kes = "": sFile.Close
End If
Application.CutCopyMode = False
dosya = Dir
Loop
Application.ScreenUpdating = True
s1.Activate
s1.Cells(1, 1).Activate
MsgBox "Bitti"
Set sFile = Nothing: Set tFile = Nothing: parcaAl = vbNullString
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End SubRE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
Currentregion için garip dediğm olayıda gif ile gösterdim.
https://resim.accesstr.net/do.php?img=10995