• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Ayrıntılı müşteri raporu

V

van_65166

Katılım
9 Kasım 2012
Mesajlar
92
Excel Vers. ve Dili
offis 7 türkce
Merhaba üstatlarım benim şimdiki sorunum başlıkta da yazdığım gibi excelden rapor almak istiyorum eğer yardım ede bilirseniz sevinirim ekteki excel dosyasına tüm açıklamaları yazdım. Tekrar aydınlatmam gereken bir alan varsa geri dönüş yapa bilirsiniz.

Yardımlarınız için şimdiden teşekkür ederim.


http://yadi.sk/d/ki_ZhXpiSufTm

http://yadi.sk/d/ki_ZhXpiSufTm
 
van_65166' Alıntı:
Merhaba üstatlarım benim şimdiki sorunum başlıkta da yazdığım gibi excelden rapor almak istiyorum eğer yardım ede bilirseniz sevinirim ekteki excel dosyasına tüm açıklamaları yazdım. Tekrar aydınlatmam gereken bir alan varsa geri dönüş yapa bilirsiniz.

Yardımlarınız için şimdiden teşekkür ederim.


http://yadi.sk/d/ki_ZhXpiSufTm

http://yadi.sk/d/ki_ZhXpiSufTm
Genişletmek için tıkla ...

Sorunuzu fonksiyonlar bölümünde açmışsınız.
Farklı bir dosyaya rapor için sorunuzu makrolar bölümünde sorsaydınız iyi olurdu.

Makro ile çözüm için aşağıdaki kodu bir modülün içine koyup örnek dosyanızdaki sayfa3 de şu makroyu (Rapor_olustur) çalıştırın.



kod:

Kod: 
Sub Rapor_olustur()

a = MsgBox("aktarmak istiyormusunuz.!?", vbYesNo + vbInformation, " Rapor aktarımı")

If a = vbNo Then
Exit Sub
End If

Range("A1:C" & Rows.Count).NumberFormat = "@"
Range("A1:C" & Rows.Count).ClearContents
Range("A1:C" & Rows.Count).Interior.ColorIndex = xlNone


Cells(1, 1).Value = "TARİH"
Cells(1, 2).Value = Format(Now, "DD.MM.YYYY")


Cells(5, 2).Value = "GELEN YOLCU RAPORU"
Cells(6, 1).Value = "TARİH"
Cells(6, 2).Value = "SEFER"
Cells(6, 3).Value = "YOLCU ADI SOYADI"


sat = 7 'WorkCells(Rows.Count, "A").End(3).Row + 1

For r = 4 To Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, 1).Value
aranan2 = Sheets("Sayfa1").Cells(r, 2).Value
aranan3 = Sheets("Sayfa1").Cells(r, [COLOR="Red"]3[/COLOR]).Value
Cells(sat, 1).Value = Format(Now, "DD.MM.YYYY")
Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
Cells(sat, 3).Value = Sheets("Sayfa1").Cells(r, 6).Value
sat = sat + 1
say1 = say1 + 1
Next r


Cells(sat, 2).Value = "GİDEN YOLCU RAPORU"
sat = sat + 1

For i = 4 To Worksheets("Sayfa1").Cells(Rows.Count, 8).End(3).Row
aranan1 = Sheets("Sayfa1").Cells(i, 8).Value
aranan2 = Sheets("Sayfa1").Cells(i, 9).Value
aranan3 = Sheets("Sayfa1").Cells(i, 10).Value
Cells(sat, 1).Value = Format(Now, "DD:MM:YYYY")
Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
Cells(sat, 3).Value = Sheets("Sayfa1").Cells(i, 13).Value
sat = sat + 1
say2 = say2 + 1
Next i



sat = sat + 1
Cells(sat, 1).Value = "TOPLAM GELEN YOLCU SAYISI"
Cells(sat, 3).Value = say1
sat = sat + 1
Cells(sat, 1).Value = "TOPLAM GİDEN YOLCU SAYISI"
Cells(sat, 3).Value = say2



sat = sat + 2
Cells(sat, 1).Value = "GENEL TOPLAM"
Cells(sat, 3).Value = say1 + say2


calısma_kitabı_yap


End Sub




Sub calısma_kitabı_yap()

'On Error Resume Next

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(dosya)
uzanti = fL.GetExtensionName(dosya)

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If


deger = InputBox("dosyanın adını değiştirebilirsiniz.", "UYARI!", Format(Now, "DD.MM.YYYY"))

If deger = dosya_adi Then
MsgBox "dosyanın adı bu dosya ile aynı olamaz değiştirin"
Exit Sub
End If




Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

If fL.FileExists(Kaynak & "\" & deger & "." & uzanti) = True Then
MsgBox "Bu isimde bir dosya var"
Exit Sub
End If

ActiveSheet.Copy

For Each Component In ActiveWorkbook.VBProject.VBComponents
If Component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove Component
Else
Set modul = Component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next

ActiveSheet.DrawingObjects.Delete

ActiveWorkbook.SaveAs Kaynak & deger & "." & uzanti, FileFormat:=xlNormal
ActiveWorkbook.Close False
MsgBox " Düzenleme Tamanlanmıştır..."
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If


End Sub
 
Farklı bir uygulama
Kodu sayfa1 de çalıştırın.

Kod: 
Sub aktar()


Sayfa_Adı = ActiveSheet.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(dosya)
Uzanti = fL.GetExtensionName(dosya)

If Uzanti = "xls" Then
FileFormatNum = -4143
ElseIf Uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf Uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf Uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If

Dim oBook As Object
Dim oSheet1 As Object
Set oBook = Workbooks.Add
Set oSheet1 = oBook.Worksheets(1)

oSheet1.Cells(1, 1).Value = "TARİH"
oSheet1.Cells(1, 2).Value = Format(Now, "DD.MM.YYYY")

oSheet1.Cells(5, 2).Value = "GELEN YOLCU RAPORU"
oSheet1.Cells(6, 1).Value = "TARİH"
oSheet1.Cells(6, 2).Value = "SEFER"
oSheet1.Cells(6, 3).Value = "YOLCU ADI SOYADI"

sat = 7

For r = 4 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, 1).End(3).Row
aranan1 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 1).Value
aranan2 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 2).Value
aranan3 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 2).Value
oSheet1.Cells(sat, 1).NumberFormat = "@"
oSheet1.Cells(sat, 1).Value = Format(Now, "DD.MM.YYYY")
oSheet1.Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
oSheet1.Cells(sat, 3).Value = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 6).Value
sat = sat + 1
say1 = say1 + 1
Next r

oSheet1.Cells(sat, 2).Value = "GİDEN YOLCU RAPORU"
sat = sat + 1

For i = 4 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, 8).End(3).Row
aranan1 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 8).Value
aranan2 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 9).Value
aranan3 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 10).Value
oSheet1.Cells(sat, 1).NumberFormat = "@"
oSheet1.Cells(sat, 1).Value = Format(Now, "DD:MM:YYYY")
oSheet1.Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
oSheet1.Cells(sat, 3).Value = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 13).Value
sat = sat + 1
say2 = say2 + 1
Next i


sat = sat + 1
oSheet1.Cells(sat, 1).Value = "TOPLAM GELEN YOLCU SAYISI"
oSheet1.Cells(sat, 3).Value = say1
sat = sat + 1
oSheet1.Cells(sat, 1).Value = "TOPLAM GİDEN YOLCU SAYISI"
oSheet1.Cells(sat, 3).Value = say2

sat = sat + 2
oSheet1.Cells(sat, 1).Value = "GENEL TOPLAM"
oSheet1.Cells(sat, 3).Value = say1 + say2

oSheet1.Columns("A:C").EntireColumn.AutoFit

yer = "Rapor " & Format(Now, "dd-mm-yyyy hh-nn-ss")
oBook.SaveAs (ThisWorkbook.Path & "\" & yer & "." & Uzanti), FileFormat:=FileFormatNum

oBook.Close False
MsgBox "işlem tamam"
If (ThisWorkbook.Path & "\" & yer & "." & Uzanti) <> "" Then
CreateObject("Shell.Application").Open (ThisWorkbook.Path & "\" & yer & "." & Uzanti)
End If


End Sub
 
halit3' Alıntı:
Sorunuzu fonksiyonlar bölümünde açmışsınız.
Farklı bir dosyaya rapor için sorunuzu makrolar bölümünde sorsaydınız iyi olurdu.

Makro ile çözüm için aşağıdaki kodu bir modülün içine koyup örnek dosyanızdaki sayfa3 de şu makroyu (Rapor_olustur) çalıştırın.



kod:

Kod: 
Sub Rapor_olustur()

a = MsgBox("aktarmak istiyormusunuz.!?", vbYesNo + vbInformation, " Rapor aktarımı")

If a = vbNo Then
Exit Sub
End If

Range("A1:C" & Rows.Count).NumberFormat = "@"
Range("A1:C" & Rows.Count).ClearContents
Range("A1:C" & Rows.Count).Interior.ColorIndex = xlNone


Cells(1, 1).Value = "TARİH"
Cells(1, 2).Value = Format(Now, "DD.MM.YYYY")


Cells(5, 2).Value = "GELEN YOLCU RAPORU"
Cells(6, 1).Value = "TARİH"
Cells(6, 2).Value = "SEFER"
Cells(6, 3).Value = "YOLCU ADI SOYADI"


sat = 7 'WorkCells(Rows.Count, "A").End(3).Row + 1

For r = 4 To Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, 1).Value
aranan2 = Sheets("Sayfa1").Cells(r, 2).Value
aranan3 = Sheets("Sayfa1").Cells(r, 2).Value
Cells(sat, 1).Value = Format(Now, "DD.MM.YYYY")
Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
Cells(sat, 3).Value = Sheets("Sayfa1").Cells(r, 6).Value
sat = sat + 1
say1 = say1 + 1
Next r


Cells(sat, 2).Value = "GİDEN YOLCU RAPORU"
sat = sat + 1

For i = 4 To Worksheets("Sayfa1").Cells(Rows.Count, 8).End(3).Row
aranan1 = Sheets("Sayfa1").Cells(i, 8).Value
aranan2 = Sheets("Sayfa1").Cells(i, 9).Value
aranan3 = Sheets("Sayfa1").Cells(i, 10).Value
Cells(sat, 1).Value = Format(Now, "DD:MM:YYYY")
Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
Cells(sat, 3).Value = Sheets("Sayfa1").Cells(i, 13).Value
sat = sat + 1
say2 = say2 + 1
Next i



sat = sat + 1
Cells(sat, 1).Value = "TOPLAM GELEN YOLCU SAYISI"
Cells(sat, 3).Value = say1
sat = sat + 1
Cells(sat, 1).Value = "TOPLAM GİDEN YOLCU SAYISI"
Cells(sat, 3).Value = say2



sat = sat + 2
Cells(sat, 1).Value = "GENEL TOPLAM"
Cells(sat, 3).Value = say1 + say2


calısma_kitabı_yap


End Sub




Sub calısma_kitabı_yap()

'On Error Resume Next

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(dosya)
uzanti = fL.GetExtensionName(dosya)

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If


deger = InputBox("dosyanın adını değiştirebilirsiniz.", "UYARI!", Format(Now, "DD.MM.YYYY"))

If deger = dosya_adi Then
MsgBox "dosyanın adı bu dosya ile aynı olamaz değiştirin"
Exit Sub
End If




Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

If fL.FileExists(Kaynak & "\" & deger & "." & uzanti) = True Then
MsgBox "Bu isimde bir dosya var"
Exit Sub
End If

ActiveSheet.Copy

For Each Component In ActiveWorkbook.VBProject.VBComponents
If Component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove Component
Else
Set modul = Component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next

ActiveSheet.DrawingObjects.Delete

ActiveWorkbook.SaveAs Kaynak & deger & "." & uzanti, FileFormat:=xlNormal
ActiveWorkbook.Close False
MsgBox " Düzenleme Tamanlanmıştır..."
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If


End Sub
Genişletmek için tıkla ...



merhaba kodu 3. sayfada çalıştırdığım zaman yanlış gelen yolcu kısmını yanlış veriyor.


örnek; 123-bur-bur

olması gereken 123-bur-ist
 
halit3' Alıntı:
Farklı bir uygulama
Kodu sayfa1 de çalıştırın.

Kod: 
Sub aktar()


Sayfa_Adı = ActiveSheet.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(dosya)
Uzanti = fL.GetExtensionName(dosya)

If Uzanti = "xls" Then
FileFormatNum = -4143
ElseIf Uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf Uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf Uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If

Dim oBook As Object
Dim oSheet1 As Object
Set oBook = Workbooks.Add
Set oSheet1 = oBook.Worksheets(1)

oSheet1.Cells(1, 1).Value = "TARİH"
oSheet1.Cells(1, 2).Value = Format(Now, "DD.MM.YYYY")

oSheet1.Cells(5, 2).Value = "GELEN YOLCU RAPORU"
oSheet1.Cells(6, 1).Value = "TARİH"
oSheet1.Cells(6, 2).Value = "SEFER"
oSheet1.Cells(6, 3).Value = "YOLCU ADI SOYADI"

sat = 7

For r = 4 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, 1).End(3).Row
aranan1 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 1).Value
aranan2 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 2).Value
aranan3 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 2).Value
oSheet1.Cells(sat, 1).NumberFormat = "@"
oSheet1.Cells(sat, 1).Value = Format(Now, "DD.MM.YYYY")
oSheet1.Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
oSheet1.Cells(sat, 3).Value = ThisWorkbook.Sheets(Sayfa_Adı).Cells(r, 6).Value
sat = sat + 1
say1 = say1 + 1
Next r

oSheet1.Cells(sat, 2).Value = "GİDEN YOLCU RAPORU"
sat = sat + 1

For i = 4 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, 8).End(3).Row
aranan1 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 8).Value
aranan2 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 9).Value
aranan3 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 10).Value
oSheet1.Cells(sat, 1).NumberFormat = "@"
oSheet1.Cells(sat, 1).Value = Format(Now, "DD:MM:YYYY")
oSheet1.Cells(sat, 2).Value = aranan1 & "-" & aranan2 & "-" & aranan3
oSheet1.Cells(sat, 3).Value = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 13).Value
sat = sat + 1
say2 = say2 + 1
Next i


sat = sat + 1
oSheet1.Cells(sat, 1).Value = "TOPLAM GELEN YOLCU SAYISI"
oSheet1.Cells(sat, 3).Value = say1
sat = sat + 1
oSheet1.Cells(sat, 1).Value = "TOPLAM GİDEN YOLCU SAYISI"
oSheet1.Cells(sat, 3).Value = say2

sat = sat + 2
oSheet1.Cells(sat, 1).Value = "GENEL TOPLAM"
oSheet1.Cells(sat, 3).Value = say1 + say2

oSheet1.Columns("A:C").EntireColumn.AutoFit

yer = "Rapor " & Format(Now, "dd-mm-yyyy hh-nn-ss")
oBook.SaveAs (ThisWorkbook.Path & "\" & yer & "." & Uzanti), FileFormat:=FileFormatNum

oBook.Close False
MsgBox "işlem tamam"
If (ThisWorkbook.Path & "\" & yer & "." & Uzanti) <> "" Then
CreateObject("Shell.Application").Open (ThisWorkbook.Path & "\" & yer & "." & Uzanti)
End If


End Sub
Genişletmek için tıkla ...



bu kod hiç çalışmadı hata veriyor
 
iki kodada yeni çalışma kitabı oluşturmuyor üstadlarım bilgilerinize
 
van_65166' Alıntı:
bu kod hiç çalışmadı hata veriyor
Genişletmek için tıkla ...

2 nolu mesajdaki kodu kırmızı yeri değiştirin.

Kod: 
aranan3 = Sheets("Sayfa1").Cells(r, [COLOR="Red"]2[/COLOR]).Value

Kod: 
aranan3 = Sheets("Sayfa1").Cells(r, [COLOR="red"]3[/COLOR]).Value
 
van_65166' Alıntı:
Üstadım ekran görüntülerini attım incelerseniz memnun olurum kesin bir yerde yanlış yapıyorumdur 2 koduda modüle kopyalayıp çalıştırdım ama başarılı olamadım

https://yadi.sk/d/vyE9ePO_T3bRA
https://yadi.sk/d/P8V1all-T3bRW
Genişletmek için tıkla ...

Aşağıdaki linkleri irdeleyiniz.

http://www.excel.web.tr/f50/runtime-error-429-activex-component-cant-create-object-t15627.html

http://www.pcnet.com.tr/forum/yazilim/81572-run-time-error-429-hakkinda.html
 
Yardımcı olan arkadaşlara sonsuz teşekkür ederim sorun çözüldü...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst