Hücrelerdeki açıklamalara göre verileri oluşturma

[istanbulcahan]

Hücrelerdeki açıklamalara göre verileri oluşturmak istiyorum. VERİLER sheetindeki
HÜCRE AÇIKLAMALARINDAKİ FİŞ NOYA VE ADA GÖRE;
VERİLERİ BURAYA YAZ sheetine veri başlıklarına göre otomatikman yazması nasıl yapılabilir.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Aciklama_Getir()

    Dim Wf As WorksheetFunction, Sv As Worksheet, i As Long, c As Range, s As Integer

    Set Wf = WorksheetFunction
    Set Sv = Sheets("[COLOR="red"]VERİLER[/COLOR]")
    
    Application.ScreenUpdating = False
    Sheets("[COLOR="Red"]VERİLER BURAYA YAZACAK[/COLOR]").Select
    Range("C2:C" & Rows.Count).ClearContents
    Range("E2:E" & Rows.Count).ClearContents
        
    For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        Set c = Sv.[B:B].Find(Trim(Cells(i, "D")), , xlValues, xlWhole)
        If Not c Is Nothing Then
            If Wf.CountIf(Sv.Rows(1), Cells(i, "B")) > 0 Then
                s = Wf.Match(Cells(i, "B"), Sv.Rows(1), 0)
                Cells(i, "C") = Replace(Sv.Cells(c.Row, s).Comment.Text, "fiş no:", "")
                Cells(i, "E") = Sv.Cells(c.Row, s)
            End If
        End If
    Next i
    
End Sub

.

 

[istanbulcahan]

ÜSTADIM,
Bu kodlar Visual basicte "Veriler mi" "veriler buraya yazılacak" "bu çalışma kitabına"mı yazılacak

 

[Ömer]

Kodları, VBA ekranında / Insert menüsünden Module ekleyip / Module1 e kodları kopyalayıp yapıştırabilirsiniz.

Kodlarda kırmızı bölümleri sayfa adlarını temsil ettiği için işaretledim. Kendi dosyanızdaki sayfa adları, eklediğiniz örnekteki sayfa adlarından farklı ise bu bölümleri kendinize göre değiştirirsiniz.

.

 

[tahsinanarat]

Sn. Ömer, kodlarınızı deniyorum ancak herhangi bir sonuç üretmiyor, bilginize.

 

[Korhan Ayhan]

Alternatif olarak deneyebilirsiniz.

Option Explicit

Sub AÇIKLAMALARI_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Byte, Kontrol As Comment
    Dim Veri As String, Satır As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("VERİLER")
    Set S2 = Sheets("VERİLER BURAYA YAZACAK")
    
    S2.Range("A2:E" & S2.Rows.Count).ClearContents
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Satır = 2
    
    For X = 2 To Son
        If S1.Cells(X, 2) <> "" Then
            For Y = 7 To 31
                On Error Resume Next
                Set Kontrol = S1.Cells(X, Y).Comment
                On Error GoTo 0
                If Not Kontrol Is Nothing Then
                    Veri = UCase(Replace(Replace(Kontrol.Text, "ı", "I"), "i", "İ"))
                    S2.Cells(Satır, 1) = S1.Cells(X, 1)
                    S2.Cells(Satır, 2) = CDate(S1.Cells(1, Y))
                    S2.Cells(Satır, 3) = Trim(Replace(Split(Veri, ":")(1), Chr(10), ""))
                    S2.Cells(Satır, 4) = S1.Cells(X, 2)
                    S2.Cells(Satır, 5) = S1.Cells(X, Y)
                    Satır = Satır + 1
                    Set Kontrol = Nothing
                End If
            Next
        End If
    Next
    
    S2.Cells.EntireColumn.AutoFit
    
    Set Kontrol = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[istanbulcahan]

Aynı durum değişmedi.

 

[Korhan Ayhan]

Kod hiç mi çalışmıyor? Yoksa istediğiniz sonucu mu vermedi?

 

[istanbulcahan]

kod hiç çalışmıyor

 

[1903emre34@gmail.com]

Merhaba,

Dosya ekte gibidir.

 

[Ömer]

Sn. Ömer, kodlarınızı deniyorum ancak herhangi bir sonuç üretmiyor, bilginize.

"VERİLER BURAYA YAZACAK" sayfası D2 hücresindeki değeri, "veriler" sayfasında bulamadığı için değer gelmiyordur. D2 deki değeri;

"ahmet1 " olarak değilde "ahmet 1" olarak yazılırsa veriler gelir.

.