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)
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.
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.
