• DİKKAT

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

Listbox da toplama sorunu

Merhaba
Dene 19 dosyanın içindeki MİZAN sayfasındaki " B " sütununda bulanan hesap no larına göre mizan dosyasından RAPOR sayfasından " F " sütunundaki verileri alabilir miyiz?
Yapılmış olan çalışmalarda verilerin tamamı alınıyor.
Veriler formülle alındığında tablo büyüdükçe sorun yaşıyorum.Kasma yapıyor.
Teşekkürler.
http://s8.dosya.tc/server5/s6rx4e/DENE.rar.html
 
Merhaba
Ek dosyadaki gibi işinize yararmı?
http://s8.dosya.tc/server5/sibl6e/DENE.zip.html

Hız yönünden fazla bir değişiklik olmuyor ama buton kodlarını şöyle değiştirerek de kullanabilirsiniz;
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Set s1 = Sheets("MİZAN")
s1.Activate
s1.Range("E2:H" & Rows.Count).ClearContents
   s1.Columns("E:H").NumberFormat = "#,##0.00"
Set c = CreateObject("scripting.filesystemobject")
If c.FileExists(ThisWorkbook.Path & "\MİZAN.xlsm") = False Then
MsgBox "MİZAN.xlsm Dosyası bulunamadı" & vbCrLf & "Verilerin alınacağı MİZAN.xlsm dosyası bu dosyanın yanında olmalı"
Exit Sub
End If
Set con = CreateObject("Adodb.Connection")
Set dt = CreateObject("adodb.recordset")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
ThisWorkbook.Path & "\MİZAN.xlsm" & ";Extended Properties = ""Excel 12.0 Macro;HDR=no"";"
dt.Open "SELECT * FROM [RAPOR$]", con, 1, 1
While Not dt.EOF
 For s = 2 To s1.Cells(Rows.Count, "B").End(3).Row
 f = s1.Cells(s, "B").Value
 If f <> "" Then
 If s1.Cells(s, "B") = dt.Fields(0) Then s1.Cells(s, "E") = dt.Fields(5)
 End If
Next
  dt.MoveNext
     Wend
dt.Close
Set dt = Nothing
Set con = Nothing
ListBox1.RowSource = "MİZAN!a1:I" & [MİZAN!a65536].End(3).Row

'ListBox1.RowSource = ""
'ListBox1.Clear
'n = 0
'rw = s1.Cells(Rows.Count, "A").End(3).Row
'With ListBox1
'For a = 1 To rw
'If s1.Cells(a, "E") <> "" And s1.Cells(a, "E") > 0 Then
'.AddItem s1.Cells(a, 1)
'For t = 1 To 7
'.list(n, t) = s1.Cells(a, t + 1).Text
'Next
'n = n + 1
'End If
'Next
'End With
Application.Calculation = xlCalculationManual
On Error Resume Next
Set s2 = Sheets("VERİ")
v = s2.Cells(Rows.Count, "A").End(3).Row
With Sheets("MİZAN")
For p = 2 To .Cells(Rows.Count, "B").End(3).Row
.Cells(p, "F") = WorksheetFunction.SumIf(s2.Range("H2:H" & v), .Cells(p, "B").Value, s2.Range("O2:O" & v))
If CDbl(.Cells(p, "E")) - CDbl(.Cells(p, "F")) < 0 Then
.Cells(p, "G") = 0
.Cells(p, "H") = CDbl(.Cells(p, "F")) - CDbl(.Cells(p, "E"))
Else
.Cells(p, "G") = CDbl(.Cells(p, "E")) - CDbl(.Cells(p, "F"))
.Cells(p, "H") = 0
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
End Sub[/SIZE]
 
Son düzenleme:
İyi akşamlar
Rapor sayfasına getirdiğimiz verilerde değeri sıfır olan hesapların gelmemesini sağlayabilir miyiz?
 
İyi akşamlar

Yardımlarınız için teşekkür ederim.
Rapor sayfasına getirdiğimiz verilerde değeri sıfır olan hesapların gelmemesini sağlayabilir miyiz?
 
Merhaba
"Rapor form ve oradan "RAPOR" sayfasına "Veri" sayfasından gönderiliyor;
"Veri" sayfasının hangi sütunundaki; değerler sıfır olursa alınmayacak?
 
İyi akşamlar.

Yapmış olduğunuz değişiklikleri inceledim.
Teşekkür ederim.

Ancak " VERİ " sayfasındaki verilerin toplamları hesap nolarına göre" F" sütununa
alınıyordu son değişiklikte " F " sütununa toplam veriler gelmiyor.
 
vuranoğlu' Alıntı:
Ancak " VERİ " sayfasındaki verilerin toplamları hesap nolarına göre" F" sütununa
alınıyordu son değişiklikte " F " sütununa toplam veriler gelmiyor.
Genişletmek için tıkla ...
Merhaba
Son dosyanıza göre denediyseniz,
"Mizan" adlı sayfada "B" sütunu: "Hesap no" ,"Veri" sayfasında "H" sütununda yok
"ETOPLa" makrosu bulamıyor
mesela Mizan" sayfasında "Armut" hesap no:600.18.003.001.001.001.001.0001.001
"Veri" sayfasında "600.18.003.001.002"

Ayrıca yukarıdaki dosyada ki kodlarda sadece "E" sıfır, "E:H" aralığında sıfırdan büyük değer olurda; gelmesi gerekse: Kırmızı bölümde değişiklik yaparsınız;

Buton kodlarının son bölümü;
Kod: 
[SIZE="2"] 
Private Sub CommandButton1_Click()
Set s1 = Sheets("MİZAN")
'....
'.......kodlar
'.......
'...
Application.Calculation = xlCalculationAutomatic
ListBox1.RowSource = ""
ListBox1.Clear
N = 0
rw = s1.Cells(Rows.Count, "A").End(3).Row
With ListBox1
For a = 1 To rw
[COLOR="Red"]If Application.Sum(Range("E" & a & ":H" & a)) > 0 Then[/COLOR]
.AddItem s1.Cells(a, 1)
For t = 1 To 7
.list(N, t) = s1.Cells(a, t + 1).Text
Next
N = N + 1
End If
Next
End With
End Sub
 [/SIZE]
 
Teşekkürler.

Hesap uyumsuzluğuna dikkat etmemişim.Bahsettiğiniz gibi değiştirdiğimde sorun yok.
" F " sütununa getirdiğimiz değerler kdv li mizan değerleri kdv siz.Buna bağlı olarak " F " sütunundaki değerleri kdv siz getirebilir miyiz? 118/1,18=100 şeklinde
Veya getirdiğimiz mizan değerlerine kdv ekleyebilir miyiz? 100*18/100=118

501.99. gibi başlayan hesaplar kdv siz
http://www.dosya.tc/server10/qmcgpu/DENE_20.rar.html
 
Son düzenleme:
Merhaba
Benim son eklediğim dosyaya göre;
Aşağıdaki buton kodlarındaki kırmızı (Orta bölümde) satırlardan hangisini (kdv ekleyen veya düşen) isterseniz " ' " tırnak işaretini kaldırırsınız
Kod: 
 [SIZE="2"]Private Sub CommandButton1_Click()
Set s1 = Sheets("MİZAN")
s1.Activate
s1.Range("E2:H" & Rows.Count).ClearContents
   s1.Columns("E:H").NumberFormat = "#,##0.00"
Set c = CreateObject("scripting.filesystemobject")
If c.FileExists(ThisWorkbook.Path & "\MİZAN.xlsm") = False Then
MsgBox "MİZAN.xlsm Dosyası bulunamadı" & vbCrLf & "Verilerin alınacağı MİZAN.xlsm dosyası bu dosyanın yanında olmalı"
Exit Sub
End If
Set con = CreateObject("Adodb.Connection")
Set dt = CreateObject("adodb.recordset")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
ThisWorkbook.Path & "\MİZAN.xlsm" & ";Extended Properties = ""Excel 12.0 Macro;HDR=no"";"
dt.Open "SELECT * FROM [RAPOR$]", con, 1, 1
While Not dt.EOF
 For s = 2 To s1.Cells(Rows.Count, "B").End(3).Row
 f = s1.Cells(s, "B").Value
 If f <> "" Then
 If s1.Cells(s, "B") = dt.Fields(0) Then s1.Cells(s, "E") = dt.Fields(5)
 End If
Next
  dt.MoveNext
     Wend
dt.Close
Set dt = Nothing
Set con = Nothing
Application.Calculation = xlCalculationManual
On Error Resume Next
Set s2 = Sheets("VERİ")
v = s2.Cells(Rows.Count, "A").End(3).Row
With Sheets("MİZAN")
For p = 2 To .Cells(Rows.Count, "B").End(3).Row
.Cells(p, "F") = WorksheetFunction.SumIf(s2.Range("H2:H" & v), .Cells(p, "B").Value, s2.Range("O2:O" & v))
[COLOR="Red"]  'If IsNumeric(.Cells(p, "F").Value) = True And CDbl(.Cells(p, "F").Value) > 0 Then .Cells(p, "F").Value = CDbl(.Cells(p, "F").Value) / 1.18[/COLOR]
   [COLOR="Red"] 'If IsNumeric(.Cells(p, "E").Value) = True And CDbl(.Cells(p, "E").Value) > 0 Then .Cells(p, "E").Value = CDbl(.Cells(p, "E").Value) * 1.18[/COLOR]
If CDbl(.Cells(p, "E")) - CDbl(.Cells(p, "F")) < 0 Then
.Cells(p, "G") = 0
.Cells(p, "H") = CDbl(.Cells(p, "F")) - CDbl(.Cells(p, "E"))
Else
.Cells(p, "G") = CDbl(.Cells(p, "E")) - CDbl(.Cells(p, "F"))
.Cells(p, "H") = 0
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
ListBox1.RowSource = ""
ListBox1.Clear
N = 0
rw = s1.Cells(Rows.Count, "A").End(3).Row
With ListBox1
For a = 1 To rw
If s1.Cells(a, "E") <> "" And s1.Cells(a, "E") > 0 Then
.AddItem s1.Cells(a, 1)
For t = 1 To 7
.list(N, t) = s1.Cells(a, t + 1).Text
Next
N = N + 1
End If
Next
End With
End Sub[/SIZE]
 
İyi akşamlar

PLİNT
Biraz geç oldu ama yardımların için teşekkürler.
Dim X1 As Long, Y1 As Long, Y2 As Long, X2 As Long
Dim CX As Double, CY As Double
Dim MyCtrl As Control
X1 = Application.Width
Y1 = Application.Height
X2 = Me.Width
Y2 = Me.Height
CX = X1 / X2
CY = Y1 / Y2
Me.Width = X1
Me.Height = Y1
For Each MyCtrl In Me.Controls
MyCtrl.Top = MyCtrl.Top * CY
MyCtrl.Left = MyCtrl.Left * CX
MyCtrl.Width = MyCtrl.Width * CX
MyCtrl.Height = MyCtrl.Height * CY
On Error Resume Next
MyCtrl.Font.Size = MyCtrl.Font.Size * CY
On Error GoTo 0

kod larla sayfanın tam ekran olmasını sağlıyorum.ancak her sayfa için yazmak gerekiyor.Tüm sayfalarda uygulamak için nasıl yapmak gerekir.
Rapor sayfasında tüm hesapları iki tarih arası görmek için nasıl bir değişiklik gerekir?
 
Son düzenleme:
vuranoğlu' Alıntı:
kod larla sayfanın tam ekran olmasını sağlıyorum.ancak her sayfa için yazmak gerekiyor.Tüm sayfalarda uygulamak için nasıl yapmak gerekir.
Genişletmek için tıkla ...
Merhaba
Yukarıdaki kodlarnız ek dosyadaki gibi düzenlenebilir;
http://s8.dosya.tc/server5/blv54z/userfom.zip.html
(Tüm; tam ekran olması istenilen) "Userform" 'un/ların kod sayfasına:
Kod: 
[SIZE="2"]Private Sub UserForm_Initialize()
Call yt
End Sub[/SIZE]
Module:
Kod: 
[SIZE="2"]Sub yt()
Dim nm As Object
For Each a In VBA.UserForms
Set nm = a
If Application.Width <> nm.Width Then
Dim X1 As Long, Y1 As Long, Y2 As Long, X2 As Long
Dim CX As Double, CY As Double
Dim MyCtrl As Control
X1 = Application.Width
Y1 = Application.Height
X2 = nm.Width
Y2 = nm.Height
CX = X1 / X2
CY = Y1 / Y2
nm.Width = X1
nm.Height = Y1
For Each MyCtrl In nm.Controls
MyCtrl.Top = MyCtrl.Top * CY
MyCtrl.Left = MyCtrl.Left * CX
MyCtrl.Width = MyCtrl.Width * CX
MyCtrl.Height = MyCtrl.Height * CY
On Error Resume Next
MyCtrl.Font.Size = MyCtrl.Font.Size * CY
On Error GoTo 0
Next
End If
Next
End Sub[/SIZE]

vuranoğlu' Alıntı:
Rapor sayfasında tüm hesapları iki tarih arası görmek için nasıl bir değişiklik gerekir?
Genişletmek için tıkla ...
Değişecek "Private Sub ComboBox1_Click()" kodları:
http://s8.dosya.tc/server5/rgvejg/combobox1_kodlari.txt.html
Değişecek "Sub liste" kodları:
http://s4.dosya.tc/server5/04lk13/sub_liste_kodlari.txt.html
 
İyi akşamlar
Teşekkürler
Bu çalışmayı sene değiştiğinde yeni seneye ait klasör oluşturarak dosya içine kopyalayabilir miyiz?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst