• DİKKAT

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

Bir tablodan diğer sayfalara ayıklama, süzme

  • Konbuyu başlatan Konbuyu başlatan gkhn2
  • Başlangıç tarihi Başlangıç tarihi
gkhn2

gkhn2

Katılım
20 Aralık 2013
Mesajlar
195
Excel Vers. ve Dili
Microsoft Office Standart 2013 - Microsoft Windows 10 Enterprise
SELAMIN ALEYKÜM
İYİ GÜNLER

ŞÖYLE BİR SORUM OLACAK

"ADANA $" SAYFASINA; RAPOR SAYFASINDAKİ ADANA MÜŞTERİLERİNİN DOLAR BAKİYELERİNİ,

"ADANA TL" SAYFASINA İSE TL BAKİYELERİNİ ÇEKMEK İSTİYORUM.

AYNI ŞEKİLDE TRABZON İÇİN VS.. İÇİN

http://www.dosya.tc/server38/1cHtsO/BADENEME.xlsx.html
 
selamun aleykum,
başka bir siteye yüklermisiniz. antivirüs uyarı veriyor da.
 
selamun aleykum,
google drive ya yüklermisiniz :( çalıştığım şirkette bu siteler engelli. yada engeli olmayan başka bir arkadaşım bakabilir.
 
Ya PERSONAL.XLSB dosyasında makro var ondan virüs sanıyo programlar. Yemeğe çıktım dönüşte temizliyip yükliycem.
 
gkhn2' Alıntı:
SELAMIN ALEYKÜM
İYİ GÜNLER
ŞÖYLE BİR SORUM OLACAK
"ADANA $" SAYFASINA; RAPOR SAYFASINDAKİ ADANA MÜŞTERİLERİNİN DOLAR BAKİYELERİNİ,
"ADANA TL" SAYFASINA İSE TL BAKİYELERİNİ ÇEKMEK İSTİYORUM.
AYNI ŞEKİLDE TRABZON İÇİN VS.. İÇİN
Genişletmek için tıkla ...
ALEYKÜM SELAM
Dosyanızdaki durum değişmeyecekse şöyle deneyin;
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Dim sf1, c As Worksheet
Dim a, b As Long, i As Integer
b = 3
Set sf1 = Sheets(1)
For i = 1 To Sheets.Count
If Sheets(i).Name <> ActiveSheet.Name Then _
Sheets(i).[a4:g65000] = Empty
Next
For a = 4 To sf1.Cells(Rows.Count, 1).End(xlUp).Row
If Trim(sf1.Cells(a, 3).Value) = "DOLAR" Then k = "$" Else k = "TL"
Set c = Sheets(Trim(sf1.Cells(a, 2)) & " " & k)
c.Range("a" & c.Cells(Rows.Count, 1).End(3).Row + 1 & ":g" & c.Cells(Rows.Count, 1).End(3).Row + 1).Value = _
sf1.Range("a" & a & ":g" & a).Value
Next
End Sub[/SIZE]

Döviz ve iller çeşitlenecekse aşağıdaki dosya daha uygun;
http://www.upturkey.com/download.php?file=905BADENEME.xls
 
PLİNT' Alıntı:
ALEYKÜM SELAM
Dosyanızdaki durum değişmeyecekse şöyle deneyin;
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Dim sf1, c As Worksheet
Dim a, b As Long, i As Integer
b = 3
Set sf1 = Sheets(1)
For i = 1 To Sheets.Count
If Sheets(i).Name <> ActiveSheet.Name Then _
Sheets(i).[a4:g65000] = Empty
Next
For a = 4 To sf1.Cells(Rows.Count, 1).End(xlUp).Row
If Trim(sf1.Cells(a, 3).Value) = "DOLAR" Then k = "$" Else k = "TL"
Set c = Sheets(Trim(sf1.Cells(a, 2)) & " " & k)
c.Range("a" & c.Cells(Rows.Count, 1).End(3).Row + 1 & ":g" & c.Cells(Rows.Count, 1).End(3).Row + 1).Value = _
sf1.Range("a" & a & ":g" & a).Value
Next
End Sub[/SIZE]

Döviz ve iller çeşitlenecekse aşağıdaki dosya daha uygun;
http://www.upturkey.com/download.php?file=905BADENEME.xls
Genişletmek için tıkla ...


kardeşim eline sağlık süper bişey olmuş. fakat şöyle oluyor. o liste her hafta değişiyor ve adana artvin gebze samsun trabzon olarak 5 il oluyor. ben kısa olsun diye öyle yaptım. bir de cariler eksilebiliyor ya da yeni cari gelebiliyor. bakiyeler değişebiliyor. nasıl bi çözüm olabilir?

mesela şöyle bir liste olabiliyor ve haftaya değişiyor

http://www.upturkey.com/download.php?file=714ba_makro.xlsx
 
gkhn2' Alıntı:
kardeşim eline sağlık süper bişey olmuş. fakat şöyle oluyor. o liste her hafta değişiyor ve adana artvin gebze samsun trabzon olarak 5 il oluyor. ben kısa olsun diye öyle yaptım. bir de cariler eksilebiliyor ya da yeni cari gelebiliyor. bakiyeler değişebiliyor. nasıl bi çözüm olabilir?

mesela şöyle bir liste olabiliyor ve haftaya değişiyor
Genişletmek için tıkla ...
Sanırım eklediğim dosyaya bakmamışsınız fazla il ve çok çeşitli dövizler olsa bile
dosyadaki kodlar uygundur.


Buda son eklediğinize göre

http://www.upturkey.com/download.php?file=434Kopya Xl0.xls
 
Son düzenleme:
baktım dostum indirdim ama bilemedim iller fazlalaşınca ve bakiyeler ile cariler değişince o makro işe yarar mı diye kusuruma bakma
 
gkhn2' Alıntı:
baktım dostum indirdim ama bilemedim iller fazlalaşınca ve bakiyeler ile cariler değişince o makro işe yarar mı diye kusuruma bakma
Genişletmek için tıkla ...
Dosyadaki kodlar şöyle
(Dosyanızda sadece Liste olan 1.sayfayı bırakın diğerlerini silin
sayfaya bir düğme veya buton ekleyin.)
Kod: 
Private Sub CommandButton1_Click()
Dim sf1, c As Worksheet
Dim a, b As Long, i, sf As Integer
b = 3
Set sf1 = Sheets(1)
For i = 1 To Sheets.Count
If Sheets(i).Name <> ActiveSheet.Name Then _
Sheets(i).[a4:g65000] = Empty
Next
Application.ScreenUpdating = False
For a = 4 To sf1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Sheets.Count
If Sheets(i).Name = Trim(sf1.Cells(a, 2).Value) & " " & Trim(sf1.Cells(a, 3).Value) Then
sf = 1
End If
Next
If sf = 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Trim(sf1.Cells(a, 2).Value) & " " & Trim(sf1.Cells(a, 3).Value)
Sheets(Sheets.Count).Range("a3:g3").Value = Sheets(1).Range("a3:g3").Value
For i = 1 To 5
Sheets(Sheets.Count).Columns(i).ColumnWidth = Sheets(1).Columns(i).ColumnWidth
Next
End If
Set c = Sheets(Trim(sf1.Cells(a, 2).Value) & " " & Trim(sf1.Cells(a, 3).Value))
c.Range("a" & c.Cells(Rows.Count, 1).End(3).Row + 1 & ":g" & c.Cells(Rows.Count, 1).End(3).Row + 1).Value = _
sf1.Range("a" & a & ":g" & a).Value
sf = 0
Next
Application.ScreenUpdating = True
End Sub
 
tamamdır dostum oldu çok sağol Allah razı olsun senden emeğine sağlık
 
gkhn2' Alıntı:
yanlız yeni açılan sayfalarda otomatik biçimlendirme yapabiliyor muyuz?

çünkü vereceğim rapor şu şekilde olacak
Genişletmek için tıkla ...
Merhaba
Kodları inceleyin


Kod: 
Private Sub CommandButton1_Click()
Dim sf1, c As Worksheet
Dim a, b As Long, i, sf As Integer
b = 3
Set sf1 = Sheets(1)
For i = 1 To Sheets.Count
If Sheets(i).Name <> ActiveSheet.Name Then _
Sheets(i).[a3:g65000] = Empty
Next
Application.ScreenUpdating = False
For a = 4 To sf1.Cells(Rows.Count, 1).End(xlUp).Row
If Trim(sf1.Cells(a, 2).Value) <> "" And Trim(sf1.Cells(a, 3).Value) <> "" Then
For i = 1 To Sheets.Count
If Sheets(i).Name = Trim(sf1.Cells(a, 2).Value) & " " & Trim(sf1.Cells(a, 3).Value) Then
sf = 1
End If
Next
If sf = 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Trim(sf1.Cells(a, 2).Value) & " " & Trim(sf1.Cells(a, 3).Value)
Sheets(Sheets.Count).Range("a2").Value = "S.NO"
Sheets(Sheets.Count).Range("b2").Value = Sheets(1).Range("a3").Value
Sheets(Sheets.Count).Range("c2:f2").Value = Sheets(1).Range("d3:g3").Value
End If
Set c = Sheets(Trim(sf1.Cells(a, 2).Value) & " " & Trim(sf1.Cells(a, 3).Value))
c.Range("b" & c.Cells(Rows.Count, 2).End(3).Row + 1).Value = _
sf1.Range("a" & a).Value
c.Range("c" & c.Cells(Rows.Count, 2).End(3).Row & ":f" & c.Cells(Rows.Count, 2).End(3).Row).Value = _
sf1.Range("d" & a & ":g" & a).Value
sf = 0
End If
Next
Application.ScreenUpdating = True
For a = 2 To Sheets.Count
Sheets(a).Columns(1).ColumnWidth = 4
Sheets(a).Columns(2).ColumnWidth = 47.57
Sheets(a).Columns("c:F").ColumnWidth = 14.43
Sheets(a).Range("a:f").Font.Name = "Calibri"
Sheets(a).Range("a2:f" & Sheets(a).Cells(Rows.Count, 2).End(3).Row + 1).Font.FontStyle = "Bold"
Sheets(a).Range("a2:f" & Sheets(a).Cells(Rows.Count, 2).End(3).Row + 1).Font.Size = 9
Sheets(a).Range("c3:f" & Sheets(a).Cells(Rows.Count, 2).End(3).Row).Font.FontStyle = 1
Sheets(a).Range("c3:f" & Sheets(a).Cells(Rows.Count, 2).End(3).Row + 1).NumberFormat = "#,##0.00"
Sheets(a).Cells(Sheets(a).Cells(Rows.Count, 2).End(3).Row + 1, 2) = "TOPLAM"
   For i = 3 To 6
Sheets(a).Cells(Sheets(a).Cells(Rows.Count, 2).End(3).Row, i) = _
WorksheetFunction.Sum(Sheets(a).Range(Sheets(a).Cells(3, i), Sheets(a).Cells(Sheets(a).Cells(Rows.Count, 3).End(3).Row, i)))
   Next:
   For i = 3 To Sheets(a).Cells(Rows.Count, 2).End(3).Row - 1
Sheets(a).Cells(i, 1) = i - 2
   Next
Sheets(a).PageSetup.Orientation = xlLandscape
Sheets(a).PageSetup.Order = xlDownThenOver
With Sheets(a).Range("a2:f" & Sheets(a).Cells(Rows.Count, 2).End(3).Row)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlThin
        End With
        
Next
End Sub
 
Son düzenleme:
verdiğin kodu kopyaladım listeyi güncelledim şöyle bir hata verdi

pRPpBL.jpg


oA7R32.jpg


http://www.upturkey.com/download.php?file=544BADENEME makro.xls
 
kardeşim çok çok çok teşekkür ederim. vallahi ellerine sağlık. bu yeteneğin bende olmasını çok isterdim. o komutlara baktım baktım birazcık bişeyler anlayabildim sadece. aslında biraz bilseydim seni bu kadar uğraştırmazdım. mesela ikinci satırı ortalatabilmek ve oluşturulan sayfalarda listenin üstünde üç satır boşluk bırakmak gibi şeyleri kendim yapmak isterdim. bi de yeni sayfa değil de yeni excel dosyası açtırmak falan filan.

herşey için teşekkürler dostum. var mı yapabileceğimiz bişeyler? İstanbul'dayım ben bi yemek ısmarlıyalım :)
 
baştaki bu hata veriyor ne ki bu?
 
gkhn2' Alıntı:
baştaki bu hata veriyor ne ki bu?
Genişletmek için tıkla ...

"" yukarıdaki kodları değiştirirken kalmış. düzelttim sizde silin.
Ayrıca;
Uyguladığınız dosyada kodların ekleneceği sayfa örnekteki gibi "Sayfa1" (adı önemli değil, kod sayfasından bakın) gizli sayfalar olabilir, varsa "Biçim/Sayfa" sekmesinden bulup görünür yapın sonrada silin sadece ilk liste sayfası kalsın.(eklediğiniz dosyada vardı.)
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst