Başka sahifeden veri süzme

kemal turan · 7 Eylül 2012

Çok teşekkür ederim.
Bildirdiğiniz sutunları kendi çalışma kitabının gelen ürünler sahifesinden düşey ara ile çekiyorum ve bir problem olduğunda tamir-revize edebiliyorum.buralar makro olursa herhangi bir değişimde tekrar siazleri rahatsız edebilirm.

Satışlar sahifesinden
Satış adedi B SUTUNU
Adı soyadı Q SUTUNU
Adres V SUTUNU
Tlf R SUTUNU
Tc P SUTUNU
bilgileriniz çekersek ala olur.ben düşey ara ile çekiyordum..
Tşk.

asi_kral · 7 Eylül 2012

Benim sorularıma yanıt vermediniz_?

kemal turan · 7 Eylül 2012

asi_kral_1967' Alıntı:
Merhaba
Cinsini = AF sütunundan
Kdv = ?
Adet = B sütunundan
Birim = ? ( K Sütunu )
Birim = ? ( L Sütunu )
Soru işaretlerinin sütunlarını söyler misiniz_?

merhaba,
Size zahmet olacak ama.
kdv = H22:h42 arasındaki hücreye gelen ürün bilgisine karşılık veri sahifesinin d sutunundaki karşılık veriyi çekecek.
(K sutunu)Brimi = "adet" standart kelimedir.( eğer "h22" dolu ise "adet" gibi)
(L sutunu)Birim fiatı = H22:h42 arasındaki hücreye gelen ürün bilgisine karşılık veri sahifesinin e sutunundaki karşılık veriyi çekecek.

kemal turan · 7 Eylül 2012

dosya ektedir.

asi_kral · 8 Eylül 2012

kemal turan' Alıntı:
dosya ektedir.

Merhaba
Bu kodu deneyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H11")) Is Nothing Then Exit Sub
Dim YOL As String, AÇ As String, AÇ1 As Workbook
Dim EX As Excel.Application, S1 As Worksheet, SAT1 As Long
Dim S2 As Worksheet, S3 As Worksheet, SAT As Long
Set EX = CreateObject("Excel.Application")
Set S1 = ActiveWorkbook.Sheets("GİDEN PLANLAMA")
Set S2 = ActiveWorkbook.Sheets("VERİ")
YOL = ThisWorkbook.Path & "\"
AÇ = "İSTİKBAL.xlsm"
Set AÇ1 = Workbooks.Open(YOL & AÇ)
Set S3 = AÇ1.Sheets("SATIŞLAR")
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
S1.Range("H12:H17").ClearContents
S1.Range("H21:M" & SAT1).ClearContents
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,2,0)"
S1.Range("H12") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,7,0)"
S1.Range("H13") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,3,0)"
S1.Range("H16") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,4,0)"
S1.Range("H17") = S3.Range("XFD1")
SAT = S3.Range("A" & Rows.Count).End(xlUp).Row
S3.Range("A1:AF" & SAT).AutoFilter field:=16, Criteria1:=S1.Range("H11")
S3.Range("XFD1") = "=SUBTOTAL(3,A2:A" & SAT & ")"
If S3.Range("XFD1") > 0 Then
S3.Range("AF2:AF" & SAT).Copy Destination:=S1.Range("H21")
End If
S3.Range("A1:AF" & SAT).AutoFilter
AÇ1.Close 0
With WorksheetFunction
For SAT = 21 To SAT1
If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C:D"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With
End Sub

Not diğer dosyayı kodla açıp kapatırken kodla ileti çıkıyor onu iptal edin yada hayır butonuna basın.

kemal turan · 9 Eylül 2012

Sn.Asi kral kardeşim.
Kodumuz çok güzel emeğinize sağlık.
Fakat veri aldıktan sonra istikbal dosyası kapanmasa daha iyi olur.
Yardımcı olacaksa kod çalıştığı anda istikbal dosyasının açık olduğunu kabul edebiliriz veya mauel açabiliriz.
Veya veriyi aldıktan sonra istikbal dosyasının kapanmamasını sağlayabilirsek de olur.
İstikbal dosyasının kapatıldığı andaki yedekleme kodu bizim için önemli.Hergün çok kereler açıp kapatıyoruz
Teşekkür ederim.
Selametle kalın..

asi_kral · 10 Eylül 2012

kemal turan' Alıntı:
Sn.Asi kral kardeşim.
Kodumuz çok güzel emeğinize sağlık.
Fakat veri aldıktan sonra istikbal dosyası kapanmasa daha iyi olur.
Yardımcı olacaksa kod çalıştığı anda istikbal dosyasının açık olduğunu kabul edebiliriz veya mauel açabiliriz.
Veya veriyi aldıktan sonra istikbal dosyasının kapanmamasını sağlayabilirsek de olur.
İstikbal dosyasının kapatıldığı andaki yedekleme kodu bizim için önemli.Hergün çok kereler açıp kapatıyoruz
Teşekkür ederim.
Selametle kalın..

Siz dosyayı manuel açacaksanız ve kendiniz kapatacaksanız olur. Ama kodu çalıştırdığınızda dosya açık değilse hata verir o zaman. Yok kendi açsın ama kapatmasın derseniz kodu tekrar çalıştırdığınızda dosya açık olduğundan gene hata verecektir. Karar sizin hangisini yapayım.

kemal turan · 10 Eylül 2012

Günaydın Sn asi kral 67
Dosyayı kendimiz açıp kapatalım.
Tşk

asi_kral · 10 Eylül 2012

kemal turan' Alıntı:
Günaydın Sn asi kral 67
Dosyayı kendimiz açıp kapatalım.
Tşk

Merhaba
Bunu dener misiniz_?

Kod:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H11")) Is Nothing Then Exit Sub
Dim YOL As String, AÇ As String, AÇ1 As Workbook
Dim EX As Excel.Application, S1 As Worksheet, SAT1 As Long
Dim S2 As Worksheet, S3 As Worksheet, SAT As Long
Set S1 = ActiveWorkbook.Sheets("GİDEN PLANLAMA")
Set S2 = ActiveWorkbook.Sheets("VERİ")
AÇ = "İSTİKBAL.xlsm"
Set S3 = Workbooks(AÇ).Sheets("SATIŞLAR")
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
S1.Range("H12:H17").ClearContents
S1.Range("H21:M" & SAT1).ClearContents
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,2,0)"
S1.Range("H12") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,7,0)"
S1.Range("H13") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,3,0)"
S1.Range("H16") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,4,0)"
S1.Range("H17") = S3.Range("XFD1")
SAT = S3.Range("A" & Rows.Count).End(xlUp).Row
S3.Range("A1:AF" & SAT).AutoFilter field:=16, Criteria1:=S1.Range("H11")
S3.Range("XFD1") = "=SUBTOTAL(3,A2:A" & SAT & ")"
If S3.Range("XFD1") > 0 Then
S3.Range("AF2:AF" & SAT).Copy Destination:=S1.Range("H21")
End If
S3.Range("A1:AF" & SAT).AutoFilter
S3.Range("XFD1").ClearContents
With WorksheetFunction
For SAT = 21 To SAT1
If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C:D"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With
End Sub

kemal turan · 10 Eylül 2012

Süperr.
Fakat aşağıdaki bölüm çalışmıyor.Bir bakarsanız.
Tşk.

If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C

"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With

asi_kral · 10 Eylül 2012

kemal turan' Alıntı:
Süperr.
Fakat aşağıdaki bölüm çalışmıyor.Bir bakarsanız.
Tşk.

If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S1.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With

Merhaba
Aslında çalışıyorda veri bulamıyor sebebi ise C sütunundaki verilerin sonunda boşluklar mevcut.
Kodda çok defa çalışıyor bununla değiştirin.

Kod:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("c9:c3000")) Is Nothing Then Exit Sub
Selection.Copy
Range("h1").PasteSpecial Paste:=xlPasteValues
Satır = Range("h42").End(3).Row + 1
Cells(Satır, "h") = Satır - 1
Cells(Satır, "h") = [h1]
Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("h21").Select
End Sub

Sub Sil()
    Range("A9:d3000").ClearContents
End Sub


Private Sub TextBox1_Change()
Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk

    Sheets("GİDEN PLANLAMA").Activate
        
        If Range("E3") <> "" Then
            Deg = Range("E3").Value
            
        Else
            MsgBox "BİR ARAMA KRİTERİ GİRİN..."
            Exit Sub
        End If
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set vsyf = Sheets("VERİ")
    Range("A9:d3000").ClearContents


    sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
    vsyf.Range("B2").AutoFilter
    
    vsyf.Range("B2").AutoFilter field:=2, Criteria1:="=*" & Deg & "*"
    On Error Resume Next
    vsyf.Range("B2:d" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
    vsyf.Range("B2").AutoFilter


    sonsat = Range("B" & Rows.Count).End(xlUp).Row
          Set Aln = Range("C10:C" & sonsat)
        
    

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, Range("H11")) Is Nothing Then _
Application.EnableEvents = True: Application.ScreenUpdating _
= True: Exit Sub
Dim YOL As String, AÇ As String, AÇ1 As Workbook
Dim EX As Excel.Application, S1 As Worksheet, SAT1 As Long
Dim S2 As Worksheet, S3 As Worksheet, SAT As Long
Set S1 = ActiveWorkbook.Sheets("GİDEN PLANLAMA")
Set S2 = ActiveWorkbook.Sheets("VERİ")
AÇ = "İSTİKBAL.xlsm"
Set S3 = Workbooks(AÇ).Sheets("SATIŞLAR")
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
S1.Range("H12:H17").ClearContents
S1.Range("H21:M" & SAT1).ClearContents
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,2,0)"
S1.Range("H12") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,7,0)"
S1.Range("H13") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,3,0)"
S1.Range("H16") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,4,0)"
S1.Range("H17") = S3.Range("XFD1")
SAT = S3.Range("A" & Rows.Count).End(xlUp).Row
S3.Range("A1:AF" & SAT).AutoFilter field:=16, Criteria1:=S1.Range("H11")
S3.Range("XFD1") = "=SUBTOTAL(3,A2:A" & SAT & ")"
If S3.Range("XFD1") > 0 Then
S3.Range("AF2:AF" & SAT).Copy Destination:=S1.Range("H21")
End If
S3.Range("A1:AF" & SAT).AutoFilter
S3.Range("XFD1").ClearContents
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
With WorksheetFunction
For SAT = 21 To SAT1
If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S2.Range("C:D"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S2.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

kemal turan · 10 Eylül 2012

Merhaba ,
Çok teşekkür ederim.
Sizleri de bayağı yorduk.
Hakkınızı helal edin.
Selametle kalın..Yolunuz Maraşa düşerse beklerim.

asi_kral · 10 Eylül 2012

kemal turan' Alıntı:
Merhaba ,
Çok teşekkür ederim.
Sizleri de bayağı yorduk.
Hakkınızı helal edin.
Selametle kalın..Yolunuz Maraşa düşerse beklerim.

Kolay Gelsin.
İnşallah yolumuz düşerse uğrarız Allah razı Olsun.

kemal turan · 11 Eylül 2012

Merhaba sn.asi kral,
Aşağıdaki kırmızı puntolu filtre kodunu çalıştırdığımızda hata veriyor.
Vermiş olduğunuz kodda ufak bir değişilik yaptım.
Gayet güzel çalışıyor.Şu aşağıdaki kod hatasını da düzeltebilirsek sevinirim.
Tşk.
Private Sub TextBox1_Change()

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("c9:c3000")) Is Nothing Then Exit Sub
Selection.Copy
Range("h1").PasteSpecial Paste:=xlPasteValues
Satır = Range("h42").End(3).Row + 1
Cells(Satır, "h") = Satır - 1
Cells(Satır, "h") = [h1]
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("h21").Select
End Sub

Sub Sil()
Range("A9:d3000").ClearContents
End Sub

Private Sub TextBox1_Change()
Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk

Sheets("GİDEN PLANLAMA").Activate

If Range("E3") <> "" Then
Deg = Range("E3").Value

Else
MsgBox "BİR ARAMA KRİTERİ GİRİN..."
Exit Sub
End If

Application.ScreenUpdating = False
Application.EnableEvents = False

Set vsyf = Sheets("VERİ")
Range("A9:d3000").ClearContents

sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
vsyf.Range("B2").AutoFilter

vsyf.Range("B2").AutoFilter field:=2, Criteria1:="=*" & Deg & "*"
On Error Resume Next
vsyf.Range("B2:d" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
vsyf.Range("B2").AutoFilter

sonsat = Range("B" & Rows.Count).End(xlUp).Row
Set Aln = Range("C10:C" & sonsat)

Application.ScreenUpdating = True
Application.EnableEvents = True

End SubOption Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, Range("H11")) Is Nothing Then _
Application.EnableEvents = True: Application.ScreenUpdating _
= True: Exit Sub
Dim YOL As String, AÇ As String, AÇ1 As Workbook
Dim EX As Excel.Application, S1 As Worksheet, SAT1 As Long
Dim S2 As Worksheet, S3 As Worksheet, SAT As Long
Set S1 = ActiveWorkbook.Sheets("GİDEN PLANLAMA")
Set S2 = ActiveWorkbook.Sheets("VERİ")
AÇ = "İSTİKBAL.xlsm"
Set S3 = Workbooks(AÇ).Sheets("SATIŞLAR")
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
S1.Range("H12:H17").ClearContents
S1.Range("H21:M45").ClearContents
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,2,0)"
S1.Range("H12") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,7,0)"
S1.Range("H13") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,3,0)"
S1.Range("H16") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,4,0)"
S1.Range("H17") = S3.Range("XFD1")
SAT = S3.Range("A" & Rows.Count).End(xlUp).Row
S3.Range("A1:AF" & SAT).AutoFilter field:=16, Criteria1:=S1.Range("H11")
S3.Range("XFD1") = "=SUBTOTAL(3,A2:A" & SAT & ")"
If S3.Range("XFD1") > 0 Then
S3.Range("AF2:AF" & SAT).Copy Destination:=S1.Range("H21")
End If
S3.Range("A1:AF" & SAT).AutoFilter
S3.Range("XFD1").ClearContents
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
With WorksheetFunction
For SAT = 21 To SAT1
If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S2.Range("C

"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S2.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

asi_kral · 11 Eylül 2012

Merhaba
Private Sub TextBox1_Change()

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("c9:c3000")) Is Nothing Then Exit Sub
Selection.Copy
Range("h1").PasteSpecial Paste:=xlPasteValues
Satır = Range("h42").End(3).Row + 1
Cells(Satır, "h") = Satır - 1
Cells(Satır, "h") = [h1]
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("h21").Select
End Sub

Sub Sil()
Range("A9:d3000").ClearContents
End Sub

Private Sub TextBox1_Change()
Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk

Sheets("GİDEN PLANLAMA").Activate

If Range("E3") <> "" Then
Deg = Range("E3").Value

Else
MsgBox "BİR ARAMA KRİTERİ GİRİN..."
Exit Sub
End If

Application.ScreenUpdating = False
Application.EnableEvents = False

Set vsyf = Sheets("VERİ")
Range("A9:d3000").ClearContents

sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
vsyf.Range("B2").AutoFilter

vsyf.Range("B2").AutoFilter field:=2, Criteria1:="=*" & Deg & "*"
On Error Resume Next
vsyf.Range("B2:d" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
vsyf.Range("B2").AutoFilter

sonsat = Range("B" & Rows.Count).End(xlUp).Row
Set Aln = Range("C10:C" & sonsat)

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, Range("H11")) Is Nothing Then _
Application.EnableEvents = True: Application.ScreenUpdating _
= True: Exit Sub
Dim YOL As String, AÇ As String, AÇ1 As Workbook
Dim EX As Excel.Application, S1 As Worksheet, SAT1 As Long
Dim S2 As Worksheet, S3 As Worksheet, SAT As Long
Set S1 = ActiveWorkbook.Sheets("GİDEN PLANLAMA")
Set S2 = ActiveWorkbook.Sheets("VERİ")
AÇ = "İSTİKBAL.xlsm"
Set S3 = Workbooks(AÇ).Sheets("SATIŞLAR")
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
S1.Range("H12:H17").ClearContents
S1.Range("H21:M45").ClearContents
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,2,0)"
S1.Range("H12") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,7,0)"
S1.Range("H13") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,3,0)"
S1.Range("H16") = S3.Range("XFD1")
S3.Range("XFD1") = "=VLOOKUP(" & S1.Range("H11") & ",P:V,4,0)"
S1.Range("H17") = S3.Range("XFD1")
SAT = S3.Range("A" & Rows.Count).End(xlUp).Row
S3.Range("A1:AF" & SAT).AutoFilter field:=16, Criteria1:=S1.Range("H11")
S3.Range("XFD1") = "=SUBTOTAL(3,A2:A" & SAT & ")"
If S3.Range("XFD1") > 0 Then
S3.Range("AF2:AF" & SAT).Copy Destination:=S1.Range("H21")
End If
S3.Range("A1:AF" & SAT).AutoFilter
S3.Range("XFD1").ClearContents
SAT1 = S1.Range("H" & Rows.Count).End(xlUp).Row
With WorksheetFunction
For SAT = 21 To SAT1
If .CountIf(S2.Range("C:C"), S1.Cells(SAT, "H")) > 0 Then
S1.Cells(SAT, "I") = .VLookup(S1.Cells(SAT, "H"), S2.Range("C"), 2, 0)
S1.Cells(SAT, "L") = .VLookup(S1.Cells(SAT, "H"), S2.Range("C:E"), 3, 0)
If S1.Cells(SAT, "H") <> Empty Then
S1.Cells(SAT, "J") = 1
S1.Cells(SAT, "K") = "ADET"
S1.Cells(SAT, "M") = S1.Cells(SAT, "J") * Cells(SAT, "L")
End If: End If: Next: End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Kırmızı ile işaretlediğim yerleri silin. Kodu deneme şansım yok çünkü dosya elimde değil.

kemal turan · 11 Eylül 2012

Bir kez daha teşekürler.
Selametle kalın..

asi_kral · 11 Eylül 2012

kemal turan' Alıntı:
Bir kez daha teşekürler.
Selametle kalın..

Kolay gelsin.

Başka sahifeden veri süzme

kemal turan

asi_kral

Özel Üye

kemal turan

kemal turan

Ekli dosyalar

asi_kral

Özel Üye

kemal turan

asi_kral

Özel Üye

kemal turan

asi_kral

Özel Üye

kemal turan

asi_kral

Özel Üye

kemal turan

asi_kral

Özel Üye

kemal turan

asi_kral

Özel Üye

kemal turan

asi_kral

Özel Üye