Kategorileri Ayıklama

Trilenium · Çarşamba saat 17:07'de

Merhaba,

Aşağıda yer alan görüntüde sarı işaretli yer alan alanlar Ham Data Sheetimde yer almaktadır.

Ben ham data içerisinden kategorileri Data adlı sheette ayıklamak istiyorum.

Örneğin

AA-AA Category si altında yer alan verilerin yan tarafına AA yazdırmak istiyorum.

VBA da nasıl yapabilirim ?

Teşekkürler

M

Korhan Ayhan · Çarşamba saat 17:22'de

Merhaba,

Formülle çözüm önerimi belki kullanmak istersiniz..

Trilenium · Çarşamba saat 17:45'de

Korhan Ayhan' Alıntı:
Merhaba,

Formülle çözüm önerimi belki kullanmak istersiniz..

Korhan Hocam ellerinize sağlık,

Lakin bana VBA tarafı gerekiyor.

ÖmerBey · Çarşamba saat 19:11'de

Merhaba,
Deneyiniz...

PHP:

Sub kod()
Dim s As Object
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long
Dim k As String

Set s1 = Sheets("Ham Data")
Set s2 = Sheets("Data")
Set s = CreateObject("Scripting.Dictionary")

For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    If s1.Cells(a, "C") = "" Then
        k = Split(s1.Cells(a, "A").Value, "-")(0)
    ElseIf Not s.exists(s1.Cells(a, "A").Value & s1.Cells(a, "C").Value) Then
        s.Add s1.Cells(a, "A").Value & s1.Cells(a, "C").Value, k
    End If
Next

For a = 2 To s2.Cells(Rows.Count, 1).End(3).Row
    If s.exists(s2.Cells(a, "A").Value & s2.Cells(a, "C").Value) Then
        s2.Cells(a, "B") = s(s2.Cells(a, "A").Value & s2.Cells(a, "C").Value)
    Else
        s2.Cells(a, "B") = "YOK"
    End If
Next
End Sub

Trilenium · Perşembe saat 00:22'de

ÖmerBey' Alıntı:

Merhaba,
Deneyiniz...

PHP:

Sub kod()
Dim s As Object
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long
Dim k As String

Set s1 = Sheets("Ham Data")
Set s2 = Sheets("Data")
Set s = CreateObject("Scripting.Dictionary")

For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    If s1.Cells(a, "C") = "" Then
        k = Split(s1.Cells(a, "A").Value, "-")(0)
    ElseIf Not s.exists(s1.Cells(a, "A").Value & s1.Cells(a, "C").Value) Then
        s.Add s1.Cells(a, "A").Value & s1.Cells(a, "C").Value, k
    End If
Next

For a = 2 To s2.Cells(Rows.Count, 1).End(3).Row
    If s.exists(s2.Cells(a, "A").Value & s2.Cells(a, "C").Value) Then
        s2.Cells(a, "B") = s(s2.Cells(a, "A").Value & s2.Cells(a, "C").Value)
    Else
        s2.Cells(a, "B") = "YOK"
    End If
Next
End Sub

Ömer Bey merhaba

Ellerinize sağlık.

Teşekkür ederim

ÖmerBey · Perşembe saat 12:36'de

Rica ederim,
İyi çalışmalar...

Trilenium · Perşembe saat 15:35'de

ÖmerBey' Alıntı:

Merhaba,
Deneyiniz...

PHP:

Sub kod()
Dim s As Object
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long
Dim k As String

Set s1 = Sheets("Ham Data")
Set s2 = Sheets("Data")
Set s = CreateObject("Scripting.Dictionary")

For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    If s1.Cells(a, "C") = "" Then
        k = Split(s1.Cells(a, "A").Value, "-")(0)
    ElseIf Not s.exists(s1.Cells(a, "A").Value & s1.Cells(a, "C").Value) Then
        s.Add s1.Cells(a, "A").Value & s1.Cells(a, "C").Value, k
    End If
Next

For a = 2 To s2.Cells(Rows.Count, 1).End(3).Row
    If s.exists(s2.Cells(a, "A").Value & s2.Cells(a, "C").Value) Then
        s2.Cells(a, "B") = s(s2.Cells(a, "A").Value & s2.Cells(a, "C").Value)
    Else
        s2.Cells(a, "B") = "YOK"
    End If
Next
End Sub

Ömer Bey tekrar merhabalar,

Ben dışarıdan veri alma işlemi yapmaktayım.. Uyarlarım diye düşündüm ama yapamadım.

Ben 1 nolu dosya içerisinde örnek veriyi, projem adlı dosyasında yer alan Örnek Aktarim adlı sayfaya aktarılmış haliyle "Data" adlı sayfaya aktarmak istiyorum.

Bir noktaya kadar geldim ama tıkandım.

Müsait olduğunuzda bakma şansınız mümkün müdür.

ÖmerBey · Perşembe saat 18:52'de

Merhaba,
Dener misiniz?

PHP:

Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim k As String, otel_name As String, Sorgu As String
Dim trh As Date
Dim x As Integer
Dim con As Object, rs As Object

Set s1 = ThisWorkbook.Sheets("Data")
Set con = CreateObject("AdoDB.Connection")
Set rs = CreateObject("AdoDB.RecordSet")

con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & ThisWorkbook.Path & "\1.xls" & _
    ";Extended Properties=""Excel 12.0;Hdr=no"""
Sorgu = "Select * From [ARAGDETTA4.RPT$]"
rs.Open Sorgu, con, 1, 1
   
otel_name = Split(rs.Fields(5), "-")(0)
ReDim dz(1 To rs.RecordCount, 1 To 12)

Do Until rs.EOF = True
    If IsDate(rs.Fields(3)) Then
        trh = rs.Fields(3)
    ElseIf rs.Fields(0) <> "" And IsNull(rs.Fields(1) & rs.Fields(4)) Then
        k = Split(rs.Fields(0), "-")(0)
    ElseIf rs.Fields(0) <> "" And rs.Fields(1) <> "" And IsNumeric(rs.Fields(4)) Then
        x = x + 1
        dz(x, 1) = Mid(con.Properties("Data Source"), InStrRev(con.Properties("Data Source"), "\") + 1)
        dz(x, 2) = trh
        dz(x, 3) = k
        dz(x, 4) = otel_name
        dz(x, 5) = rs.Fields(0)
        dz(x, 6) = rs.Fields(1)
        dz(x, 7) = CDbl(rs.Fields(4))
        dz(x, 8) = CDbl(rs.Fields(5))
        dz(x, 9) = CDbl(rs.Fields(6))
        dz(x, 10) = CDbl(rs.Fields(7))
        dz(x, 11) = CDbl(rs.Fields(8))
        dz(x, 12) = CDbl(rs.Fields(9))
    End If
    rs.MoveNext
Loop

rs.Close
con.Close

s1.Range("A2:Z9500").ClearContents
s1.Range("A2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Trilenium · Dün 08:33 da

ÖmerBey' Alıntı:

Merhaba,
Dener misiniz?

PHP:

Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim k As String, otel_name As String, Sorgu As String
Dim trh As Date
Dim x As Integer
Dim con As Object, rs As Object

Set s1 = ThisWorkbook.Sheets("Data")
Set con = CreateObject("AdoDB.Connection")
Set rs = CreateObject("AdoDB.RecordSet")

con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & ThisWorkbook.Path & "\1.xls" & _
    ";Extended Properties=""Excel 12.0;Hdr=no"""
Sorgu = "Select * From [ARAGDETTA4.RPT$]"
rs.Open Sorgu, con, 1, 1
  
otel_name = Split(rs.Fields(5), "-")(0)
ReDim dz(1 To rs.RecordCount, 1 To 12)

Do Until rs.EOF = True
    If IsDate(rs.Fields(3)) Then
        trh = rs.Fields(3)
    ElseIf rs.Fields(0) <> "" And IsNull(rs.Fields(1) & rs.Fields(4)) Then
        k = Split(rs.Fields(0), "-")(0)
    ElseIf rs.Fields(0) <> "" And rs.Fields(1) <> "" And IsNumeric(rs.Fields(4)) Then
        x = x + 1
        dz(x, 1) = Mid(con.Properties("Data Source"), InStrRev(con.Properties("Data Source"), "\") + 1)
        dz(x, 2) = trh
        dz(x, 3) = k
        dz(x, 4) = otel_name
        dz(x, 5) = rs.Fields(0)
        dz(x, 6) = rs.Fields(1)
        dz(x, 7) = CDbl(rs.Fields(4))
        dz(x, 8) = CDbl(rs.Fields(5))
        dz(x, 9) = CDbl(rs.Fields(6))
        dz(x, 10) = CDbl(rs.Fields(7))
        dz(x, 11) = CDbl(rs.Fields(8))
        dz(x, 12) = CDbl(rs.Fields(9))
    End If
    rs.MoveNext
Loop

rs.Close
con.Close

s1.Range("A2:Z9500").ClearContents
s1.Range("A2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Çok ama çok teşekkür ederim.

Saygılarımla

Trilenium · Dün 11:13 da

Ömer Bey,

Bir folderin altında bulunan birden fazla dosyadan aynı yöntem ile veriyi almak istiyorum.

Örneğin 1.dosya bittikten sonra 2.dosyaya gitsin.. (Dosya isimleri farklı farklıdır)

İlgili kodlarda hangi araya girererk devam etmeliyim sizce.

ÖmerBey · Dün 11:54 da

Açıkçası Ado ile veri alma konusunda çok tecrübem yok, dosya değiştikçe nasıl bir sonuç çıkacağını bilemiyorum. Sizin örnek dosyanızı çoğaltarak denediğimde aşağıdaki kodla doğru sonuçlar aldım.
Deneyiniz...
Not: yol değişkenini kendi klasörünüze göre uyarlayınız.

PHP:

Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim k As String, otel_name As String, Sorgu As String
Dim trh As Date
Dim x As Integer
Dim con As Object, rs As Object

Dim yol As String, dsy As String

Set s1 = ThisWorkbook.Sheets("Data")
Set con = CreateObject("AdoDB.Connection")
Set rs = CreateObject("AdoDB.RecordSet")

s1.Range("A2:Z9500").ClearContents
yol = "D:\veri\"
dsy = Dir(yol & "*.xls")
Do While dsy <> ""
    x = 0
    con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & yol & dsy & _
        ";Extended Properties=""Excel 12.0;Hdr=no"""
    Sorgu = "Select * From A1:Z1000"
    rs.Open Sorgu, con, 1, 1
    
    otel_name = Split(rs.Fields(5), "-")(0)
    ReDim dz(1 To rs.RecordCount, 1 To 12)
  
    Do Until rs.EOF = True
        If IsDate(rs.Fields(3)) Then
            trh = rs.Fields(3)
        ElseIf rs.Fields(0) <> "" And IsNull(rs.Fields(1) & rs.Fields(4)) Then
            k = Split(rs.Fields(0), "-")(0)
        ElseIf rs.Fields(0) <> "" And rs.Fields(1) <> "" And IsNumeric(rs.Fields(4)) Then
            x = x + 1
            dz(x, 1) = Mid(con.Properties("Data Source"), InStrRev(con.Properties("Data Source"), "\") + 1)
            dz(x, 2) = trh
            dz(x, 3) = k
            dz(x, 4) = otel_name
            dz(x, 5) = rs.Fields(0)
            dz(x, 6) = rs.Fields(1)
            dz(x, 7) = CDbl(rs.Fields(4))
            dz(x, 8) = CDbl(rs.Fields(5))
            dz(x, 9) = CDbl(rs.Fields(6))
            dz(x, 10) = CDbl(rs.Fields(7))
            dz(x, 11) = CDbl(rs.Fields(8))
            dz(x, 12) = CDbl(rs.Fields(9))
        End If
        rs.MoveNext
    Loop
  
    rs.Close
    con.Close

    s1.Cells(s1.Rows.Count, "A").End(3)(2, 1).Resize(UBound(dz), UBound(dz, 2)).Value = dz
    dsy = Dir
Loop
End Sub

Trilenium · Dün 12:22 da

ÖmerBey' Alıntı:

Açıkçası Ado ile veri alma konusunda çok tecrübem yok, dosya değiştikçe nasıl bir sonuç çıkacağını bilemiyorum. Sizin örnek dosyanızı çoğaltarak denediğimde aşağıdaki kodla doğru sonuçlar aldım.
Deneyiniz...
Not: yol değişkenini kendi klasörünüze göre uyarlayınız.

PHP:

Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim k As String, otel_name As String, Sorgu As String
Dim trh As Date
Dim x As Integer
Dim con As Object, rs As Object

Dim yol As String, dsy As String

Set s1 = ThisWorkbook.Sheets("Data")
Set con = CreateObject("AdoDB.Connection")
Set rs = CreateObject("AdoDB.RecordSet")

s1.Range("A2:Z9500").ClearContents
yol = "D:\veri\"
dsy = Dir(yol & "*.xls")
Do While dsy <> ""
    x = 0
    con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & yol & dsy & _
        ";Extended Properties=""Excel 12.0;Hdr=no"""
    Sorgu = "Select * From A1:Z1000"
    rs.Open Sorgu, con, 1, 1
   
    otel_name = Split(rs.Fields(5), "-")(0)
    ReDim dz(1 To rs.RecordCount, 1 To 12)
 
    Do Until rs.EOF = True
        If IsDate(rs.Fields(3)) Then
            trh = rs.Fields(3)
        ElseIf rs.Fields(0) <> "" And IsNull(rs.Fields(1) & rs.Fields(4)) Then
            k = Split(rs.Fields(0), "-")(0)
        ElseIf rs.Fields(0) <> "" And rs.Fields(1) <> "" And IsNumeric(rs.Fields(4)) Then
            x = x + 1
            dz(x, 1) = Mid(con.Properties("Data Source"), InStrRev(con.Properties("Data Source"), "\") + 1)
            dz(x, 2) = trh
            dz(x, 3) = k
            dz(x, 4) = otel_name
            dz(x, 5) = rs.Fields(0)
            dz(x, 6) = rs.Fields(1)
            dz(x, 7) = CDbl(rs.Fields(4))
            dz(x, 8) = CDbl(rs.Fields(5))
            dz(x, 9) = CDbl(rs.Fields(6))
            dz(x, 10) = CDbl(rs.Fields(7))
            dz(x, 11) = CDbl(rs.Fields(8))
            dz(x, 12) = CDbl(rs.Fields(9))
        End If
        rs.MoveNext
    Loop
 
    rs.Close
    con.Close

    s1.Cells(s1.Rows.Count, "A").End(3)(2, 1).Resize(UBound(dz), UBound(dz, 2)).Value = dz
    dsy = Dir
Loop
End Sub

Dosyalar farklı bir klasör de bulunmaktadır. Proje ise bunun dışında.

Projeyi çalıştırdığımda klasöre değil projenin bulunduğu alandaki dosyaları okumaktadır.

ÖmerBey · Dün 12:39 da

Trilenium' Alıntı:
Dosyalar farklı bir klasör de bulunmaktadır. Proje ise bunun dışında.

11. Mesajda paylaştığım koddaki yol = "D:\veri\" satırını dosyalarınızın yer aldığı klasör yoluyla değiştirip kodu çalıştırınız.

Trilenium · Dün 13:19 da

Ömer Bey merhaba

O yolu değiştirdim. İlginç olan şey şu klasörü görüyor ama kod çalıştığında dsy = dosyanın kendisini görüyor

ÖmerBey · Dün 13:42 da

Trilenium' Alıntı:
Bir folderin altında bulunan birden fazla dosyadan aynı yöntem ile veriyi almak istiyorum.

Örneğin 1.dosya bittikten sonra 2.dosyaya gitsin.. (Dosya isimleri farklı farklıdır)

Kodu bu mesajdaki isteğinize göre uyarlamaya çalıştım. Klasör yolunu koda gösterdiğinizde kod, klasördeki bütün .xls uzantılı dosyalardan veri alır. Ya da ben isteğinizi yanlış mı anladım acaba?

Trilenium · Dün 14:07 da

Ömer Bey merhabalar,

Şöyle anlatayım;

Dosyalar_klasörü < bu klasöre sistemden aldığım raporları aktarıyorum. isimleri farklı farklı ve her seferinde isimleri değişebiliyor.

Örneğin ; c:\Proje\Dosyalar_Klasörü\*.xls

Proje dosyası ise C:\Proje altında bulunmaktadır.

Ben proje.xlsm dosyasını çalıştırıp \dosyalar_klasörü altında yer alan dosyalardan istediğim (yapmış olduğumuz gibi) data adlı sheete verileri aktaracağım.

Örneğin ; ABC.xls adlı dosyada ki veriler data adlı sheete aktarıldıktan sonra BCD.xls dosyasındaki veriler Data adlı sheette son satırdan devam edecek..

Böyle böyle 400 den fazla dosyam var...Aktarımlar bitince işlemim bitmiş olacak

ÖmerBey · Dün 14:20 da

Tekrar merhaba,
Ben de bu şekilde anlamıştım.
Yukarıda 11. mesajdaki kodu Proje.xlsm dosyanıza kopyalayınız. Yol değişkenini yol = "C:\Proje\Dosyalar_Klasörü\" olarak ayarlayıp kodu çalıştırdığınızda .xls uzantılı tüm dosyalardan sırasıyla veri aktarımı yapılması gerekiyor.
Eğer işlem gerçekleşmiyor ya da hatalı gerçekleşiyorsa dosya yapılarındaki farklılıktan kaynaklı olabilir sanıyorum.

Trilenium · Dün 14:24 da

Ömer Bey tekrar merhaba,

Bazen Türk usulü de olsa geçerli oluyor

Makineyi kapat-aç yapınca düzeldi.

Tekrar tekrar çok teşekkür ederim size.

Kolaylıklar dilerim.

Kategorileri Ayıklama

Trilenium

Destek Ekibi

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

Trilenium

Destek Ekibi

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi

Ekli dosyalar

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi

Trilenium

Destek Ekibi

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi

ÖmerBey

Destek Ekibi

Trilenium

Destek Ekibi