13/11/2020, 13:31
MTARKALI
Merhabalar Arkadaşlar
Kurumlardan sürekli olarak farklı toblolar ile veri topluyorum ve hepsini tek bir tabloda birleştiriyorum
Benim veri topladığım ana dosyam sürece göre değişebiliyor
1.satırda konu başlığı, 2. satırda da istenilen veri türü başlıkları yer alıyor
bu kodu buldum düzenledim ama ya hata veriyor ya da
1.satırdaki verileri doğrulayarak, 2.satırdan yazmaya başlıyor
bunu;
2.satırdaki verileri doğrulayarak (sürece göre bazen 1.satırdan bazen de 4.satırdan olabiliyor)
3.satırdan yazmaya başlaması gerekiyor.
işin içinden çıkamadım bi yardım lütfen
Bu resimdeki örnek tabloda 1. satırı silersem verilerim doğru geliyor.
Ama böyece ya da kodda düzeltme yapınca hata veriyor.
Kurumlardan sürekli olarak farklı toblolar ile veri topluyorum ve hepsini tek bir tabloda birleştiriyorum
Benim veri topladığım ana dosyam sürece göre değişebiliyor
1.satırda konu başlığı, 2. satırda da istenilen veri türü başlıkları yer alıyor
bu kodu buldum düzenledim ama ya hata veriyor ya da
1.satırdaki verileri doğrulayarak, 2.satırdan yazmaya başlıyor
bunu;
2.satırdaki verileri doğrulayarak (sürece göre bazen 1.satırdan bazen de 4.satırdan olabiliyor)
3.satırdan yazmaya başlaması gerekiyor.
işin içinden çıkamadım bi yardım lütfen
Kod:
Sub ImportDataFromMultipleWorkbooks()
Dim vaFiles As Variant
Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet
ThisWorkbook.Activate
Set ws = Sayfa1
un = "Sayın " & Environ("UserName")
ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
ws.Range("A2:K" & Rows.Count).Clear
lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
vaFiles = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
Title:="Select Files to Proceed", MultiSelect:=True)
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
GoTo skipfile:
End If
Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
Set wsa = ActiveWorkbook.ActiveSheet
lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row
lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column
For c = 1 To lc
For ca = 1 To lrc
If wsa.Cells(1, ca) = ws.Cells(1, c) Then
cn = ca
Exit For
End If
Next ca
For r = 2 To lra
y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row
If c <> lc Then
ws.Cells(y, c) = wsa.Cells(r, cn)
Else
ws.Cells(y, c) = "FileName: " & Mid(ActiveWorkbook.Name, 1, InStr(1, _
ActiveWorkbook.Name, ".xls") - 1)
End If
y = y + 1
Next r
Next c
wbkToCopy.Close savechanges:=False
skipfile:
Next i
ws.Range("A2:K2").EntireColumn.AutoFit
ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
Else
ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
End If
Else
ms2 = MsgBox("Başarısız!", vbInformation, un)
End If
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End SubBu resimdeki örnek tabloda 1. satırı silersem verilerim doğru geliyor.
Ama böyece ya da kodda düzeltme yapınca hata veriyor.