Kapalı Birden Çok Excel Sayfasından Veri Çekmek

Katılım
15 Ocak 2022
Mesajlar
2
Excel Vers. ve Dili
2013
Arkadaşlar merhaba,

Excel konusunda ne yazık ki çok bilgili değilim.

Çalıştığım şirkette yıl içerisinde verilmiş excel formatında teklifler var. Bu tekliflerin 1. sayfasında Genel Toplam yazılı hücrenin karşısında toplam teklif tutarı yazıyor. (Ayrıca 2. sayfa ve 3. sayfası olan teklifler de var fakat yalnızca 1. sayfada yazan genel yoplam önemli benim için)

Genel Toplam

10.000 TL


Yukarıdaki gibi

Yaklaşık bu şekilde hazırlanmış 780 excel var, bu 780 teklifin her birine ne kadar fiyat verdiğimizi çıkartmamı istiyorlar. Yani;
Teklif-1 : Genel Toplam 10.000 tl
Teklif-2 : Genel Toplam 123.000 tl
.
.
.
Teklif-780 : Genel Toplam 14.549 tl gibi.

Tüm bu excelleri teker teker açıp bakıp yazmak yerine VBA ile bir makro oluşturup, yalnızca "Genel Toplam" yazan hücrenin karşısındaki hücrede yazan tutarı çekebileceğim bir kod oluşturmak mümkün müdür ? İnternetteki araştırmamda birisi çok güzel bir kod yapmış fakat o kodu kendi istediğim şekilde nasıl düzenleyebileceğim hakkında hiçbir fikrim yok ne yazık ki.

O kod şu şekilde:

'Dugun oncesi herkese hediyem olsun :)
'Kod 09.10.2020'de gelistirildi
Option Explicit
Dim seper As String
Sub Fiyatlarıcek()

Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet
Dim rng As Range
Dim cll As Range
Dim ms1 As Integer
Dim c As Long
Dim lr, lc, lra, lrc, i, j, d, fRow, cIndex As Long
Dim un As String
Dim fHeader As Boolean
Dim vaFiles As Variant

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Dear " & Environ("UserName"): seper = "~"

ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
If ActiveWindow.WindowState <> xlMaximized Then ActiveWindow.WindowState = xlMaximized
ws.UsedRange.Offset(1, 0).Clear

ChDir (Environ("USERPROFILE") & Application.PathSeparator & "Desktop")
vaFiles = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
Title:="Select Files to Proceed", MultiSelect:=True)

On Error GoTo errPlace

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

lc = FindRowColumn(ws, "c")
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
MsgBox "Cannot Open Itself", vbExclamation, un
GoTo skipfile:
End If

Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
Set wsa = ActiveWorkbook.ActiveSheet

lra = FindRowColumn(wsa, "r")
lrc = FindRowColumn(wsa, "c")

For c = 1 To lc
fHeader = False: cIndex = 0: fRow = fAvaRow(ws, c, FindRowColumn(ws, "c"))
For Each cll In wsa.UsedRange.Cells
If CleanHeading(cll.Value) = CleanHeading(ws.Cells(1, c)) Then
cIndex = cll.Column
fHeader = True
Exit For
End If
Next cll
If fHeader = True Then
With wsa
.Range(.Cells(cll.Offset(1, 0).Row, cIndex), _
.Cells(lra, cIndex)).Copy ws.Cells(fRow, c)
End With
ws.Cells(1, c) = ws.Cells(1, c) & seper
End If
Next c
With ws
On Error GoTo 0
If .Cells(1, lc) <> "Dosya Ismi" Then .Cells(1, lc).Offset(0, 1) = _
"Dosya Ismi": lc = FindRowColumn(ws, "c")
If CheckDataImport(ws) = False Then
.Range("A" & FindRowColumn(ws, "r")).Offset(1, 0).Resize(1, lc) = _
"Dosyada Eslesen Hic Data Bulunamadi"
.UsedRange.Cells(.UsedRange.Cells.Count) = wsa.Parent.FullName
wsa.Parent.Close False
GoTo skipfile
End If
.UsedRange.Resize(, 1).Offset(, lc - 1).SpecialCells(xlCellTypeBlanks) = _
wbkToCopy.FullName: lr = FindRowColumn(ws, "r")
For j = 1 To lc
Set rng = .Range(.Cells(fRow, j), .Cells(lr, j))
If Application.CountA(rng) = 0 And _
Right(.Cells(1, j), Len(seper)) <> seper Then
rng.Value = "Bulunamadi"
Else
If Right(.Cells(1, j), Len(seper)) = seper Then .Cells(1, j) = _
Left(.Cells(1, j), Len(.Cells(1, j)) - Len(seper))
End If
Next j
.UsedRange.EntireColumn.AutoFit
With .Parent.Parent
.StatusBar = "-->> " & wbkToCopy.Name & " Aktarildi"
.Wait Now + TimeValue("00:00:01")
End With
End With
wbkToCopy.Close False
skipfile:
Next i
MsgBox "Data Import Finished", vbInformation, un
Else
MsgBox "No Files Selected", vbExclamation, un
End If
Else
MsgBox "Cancelled", vbInformation, un
End If

proceedEnd:

With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With

Exit Sub

errPlace:

For Each cll In ws.UsedRange.Resize(1)
If Right(cll.Value, Len(seper)) = seper Then
cll.Value = Left(cll.Value, Len(cll.Value) - Len(seper))
End If
Next cll

MsgBox "An Error Occured" & vbNewLine & vbNewLine & _
"-->> Error No: " & Err.Number & vbNewLine & _
"-->> Error Description: " & Err.Description, vbExclamation, un

GoTo proceedEnd

End Sub
Private Function FindRowColumn(inpSht As Worksheet, sInp As String)

With inpSht
If LCase(sInp) = "r" Then
FindRowColumn = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
ElseIf LCase(sInp) = "c" Then
FindRowColumn = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
FindRowColumn = 0
End If
End With

End Function
Private Function CleanHeading(sInput As String) As String

CleanHeading = LCase(Trim(Application.Clean(sInput)))

End Function
Private Function fAvaRow(inpShtAva As Worksheet, inpC As Long, inpLastCol As Long)

Dim c As Long

fAvaRow = 0
For c = inpC To inpLastCol
If inpShtAva.Cells(Rows.Count, c).End(xlUp).Row > fAvaRow Then
fAvaRow = inpShtAva.Cells(Rows.Count, c).End(xlUp).Row
End If
Next c
If fAvaRow <> 0 Then fAvaRow = fAvaRow + 1

End Function
Private Function CheckDataImport(inpDataSheet As Worksheet) As Boolean

Dim cll As Range

CheckDataImport = False
For Each cll In inpDataSheet.UsedRange.Resize(1).Cells
If Right(cll.Value, Len(seper)) = seper Then
CheckDataImport = True
Exit Function
End If
Next cll

End Function

video linki de :

Bilgili arkaaşlarım yardımcı olursa çok memnun olurum, şimdiden teşekkür ederim.
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
34,182
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ofis 2016 Tr-En 32 Bit
Merhaba,

Burada önemli olan GENEL TOPLAM hücreleri hep aynı hücrede mi bulunuyor.

Yazılacak makro buna göre düzenlenecektir. Bu sebeple bir kaç veri alınacak örnek dosya ve görmek istediğiniz sonucu içeren bir örnek dosyayı paylaşırsanız yardım almanız kolaylaşır.
 
Katılım
15 Ocak 2022
Mesajlar
2
Excel Vers. ve Dili
2013
Korhan bey,

Öncelikle ilginiz için teşekkür ederim.
Maalesef hepsi aynı hücrede oluyor üste eklenen satırlar olduğu için hücre numarası kayabiliyor.
 
Üst