Kategorileri Ayıklama

Trilenium · 3 Temmuz 2024

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 · 3 Temmuz 2024

Merhaba,

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

Trilenium · 3 Temmuz 2024

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 · 3 Temmuz 2024

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 · 4 Temmuz 2024

Ö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 · 4 Temmuz 2024

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

Trilenium · 4 Temmuz 2024

Ö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 · 4 Temmuz 2024

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 · 5 Temmuz 2024

Ö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 · 5 Temmuz 2024

Ö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 · 5 Temmuz 2024

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 · 5 Temmuz 2024

Ö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 · 5 Temmuz 2024

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 · 5 Temmuz 2024

Ö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 · 5 Temmuz 2024

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 · 5 Temmuz 2024

Ö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 · 5 Temmuz 2024

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 · 5 Temmuz 2024

Ö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.

Trilenium · 17 Temmuz 2024

Ömer Bey merhaba,

Aynı denemeyi farklı bir raporumda denediğimde başarılı olamadım. Aşağıda belirttiğim gibi tarihi görmeyip döngü dışına çıkıyor.

Almak istediğim elemanları işaretledim. Müsait anınızda bakma şansınız var mıdır?

Şöyle ki;

IsDate(rs.Fields(3)) Then

trh = Trim(rs.Fields(3)) <<< Tarihi görüyor ama tarih olarak adletmediği için yok sayıp döngünün dışına çıkıyor.

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)

Trilenium · 18 Temmuz 2024

Konu günceldir.

Kategorileri Ayıklama

Destek Ekibi

Ekli dosyalar

Administrator

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Ekli dosyalar

Destek Ekibi