Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Kodlarda revize (http://www.excel.web.tr/showthread.php?t=170437)

1903emre34@gmail.com 09-02-2018 20:04

Kodlarda revize
 
Merhaba,

Aşağıdaki kod ile Ocak-Eylül/2017 dosyalarda yer alan tarihleri ve tutarları ana sayfa aktarmaktadır, ama Ekim-Aralık/2017 dosyalarda verileri aktarmamaktadır.

Kod:

Private Sub CommandButton1_Click()
With Range("A2:C" & Rows.Count)
.ClearContents
.NumberFormat = "m/d/yyyy"
End With
Columns("B:B").NumberFormat = "#,##0.00"
Columns("C:C").NumberFormat = "0"
Range("G12:J23").ClearContents
Application.Calculation = xlCalculationManual
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path)
Set dc = f.Files
For Each dosya In dc
If dosya.Name <> ThisWorkbook.Name And InStr(1, dosya.Name, "~", vbTextCompare) = 0 Then
If ds.GetExtensionName(dosya.Name) Like "xls*" Then
ad = UCase(Replace(Replace(ds.GetBaseName(dosya.Name), "i", "İ"), "ı", "I"))
q = Array("OC", "ŞU", "MAR", "NİS", "MAY", "HAZ", "TEM", "AĞ", "EY", "EK", "KAS", "ARA")
For p = 0 To UBound(q)
If InStr(1, ad, q(p), vbTextCompare) > 0 Then s = Format(p + 1, "00"): Exit For
Next
Set Aç = New Excel.Application
Aç.Workbooks.Open dosya
Set hz = Aç.Workbooks(Dir(dosya))
If hz.Sheets.Count < 3 Then
MsgBox dosya.Name & " dosyasında 3. sayfa bulunamadı"
GoTo 10
End If
Set ss = hz.Sheets(3)
ss.Activate
Set v = ss.Range("E:F").Find("Belge trh", , , xlPart, xlNext, xlNext, False)
If Not v Is Nothing Then
rw = ss.Cells(Rows.Count, v.Column).End(3).Row
rv = Cells(Rows.Count, "A").End(3).Row + 1
ss.Range(ss.Cells(v.Row, v.Column), ss.Cells(rw, v.Column)).NumberFormat = "m/d/yyyy"
Cells(rv, 1).Select
Range(Cells(rv, 1), Cells(rv + rw, 1)).Value = _
ss.Range(ss.Cells(v.Row, v.Column), ss.Cells(rw, v.Column)).Value

Range(Cells(rv, 2), Cells(rv + rw, 2)).Value = _
ss.Range(ss.Cells(v.Row, v.Column + 2), ss.Cells(rw, v.Column + 2)).Value

Range(Cells(rv, 3), Cells(rv + rw, 3)).Value = _
ss.Range(ss.Cells(v.Row, v.Column + 1), ss.Cells(rw, v.Column + 1)).Value

rv2 = Cells(Rows.Count, 1).End(xlUp).Row
 For j = rv2 To rv Step -1
 If IsDate(Cells(j, 1).Value) = True Then
 gün = Format(Replace(Cells(j, 1).Text, " ", ""), "dd")
 yıl = Format(Replace(Cells(j, 1).Text, " ", ""), "yyyy")
bak = CDate(WorksheetFunction.EoMonth(CDate("01 " & s & " " & yıl), 0))
bak = Format(bak, "dd")
If gün > bak Then gün = bak
 Cells(j, 1) = CDate(Format(gün & " " & s & " " & yıl, "dd.mm.yyyy"))
 Else
    Range("A" & j & ":C" & j).Delete Shift:=xlUp
 rv2 = rv2 - 1
 End If
 Next
Range("A" & rv & ":C" & rv2).Sort Key1:=Cells(rv, 1), Order1:=xlAscending
End If
10:
hz.Close SaveChanges:=False
Aç.Quit

End If: End If
Set Aç = Nothing
Next
Application.Calculation = xlCalculationAutomatic
[F10].Select
rv2 = Cells(Rows.Count, "A").End(3).Row
Range("A2:C" & rv2).Sort Key1:=Cells(2, 1), Order1:=xlAscending
Range("G12:H23").Formula = _
        "=IF(R11C=" & [G10].Text & ",IF(RC9<-1*RC10,-1*RC10-RC9,""""),IF(R11C=" & [H10].Text & ",IF(RC9>-1*RC10,IF(RC9>-1*RC10,RC9-(-1*RC10),-1*RC10-RC9),"""")))"
Range("I12:J23").Formula = _
        "=SUMPRODUCT((MONTH(INDIRECT(""A2:A""&sonsat))=ROW(R[-11]C[-8]))*(INDIRECT(""C2:C""&sonsat)=R11C[-2])*(INDIRECT(""B2:B""&sonsat)))"

End Sub


YUSUF44 09-02-2018 23:02

Tam inceleyemedim ancak tek basamaklı ayları aktarıp iki basamaklıları aktarmadığı anlaşılıyor. Bu da tarih biçiminin "d/m/yyyy" olmasından kaynaklanıyor muhtemelen. "dd/mm/yyyy" yaparsanız düzelebilir.


Saat 20:26

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.