sayfalara veri aktarımı

[ali14]

makro ile butona basınca ANALİZ sayfasındaki verileri kendi adındaki sayfalara (yani A sutununda ADEL var hemen ADEL sayfasına kendi satırlarındaki veriler gidecek) fakat veriler günlük yenileneceğinde yeni veri hep üst sütunda olcak (yani eski veri silinmeyecek kendiliginden satır eklenmiş olcak)

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

 

[ali14]

Ya varya bu site deki uzman arkadaşlar bir harika KORHAN BEY COK TEŞEKKÜRLER

 

[hhaseken]

Süper tebrikler elinize sağlık

 

[ali14]

Aşağıdaki kodun neresini değiştirmeliyim ki veri yi kayıd ederken yeni veri hep üstte olsun(yani sayfaya her yeni veri aktardığımda yeni veri en alt satırda oluyo ben hep üst satırda olsun istiyorum)

Sub SAYFALARA_DAĞIT()
Dim S1 As Worksheet
Dim SY As Worksheet
Dim X As Long
Dim SATIR As Long

Set S1 = Sheets("ANALİZ")

Application.ScreenUpdating = False

For X = 1 To S1.Range("A65536").End(3).Row
If S1.Cells(X, 1) <> "" Then
If InStr(1, S1.Cells(X, 1), "İMKB") = 0 Then
If InStr(1, S1.Cells(X, 1), "Yüksek") = 0 Then
If InStr(1, S1.Cells(X, 1), "[") = 0 Then
If Not IsNumeric(S1.Cells(X, 1)) Then

If SAYFA(S1.Cells(X, 1)) Then

SATIR = Sheets(CStr(S1.Cells(X, 1))).Range("A65536").End(3).Row + 1
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 1) = S1.Cells(X, 2)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 2) = S1.Cells(X, 3)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 3) = S1.Cells(X, 4)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 4) = S1.Cells(X, 5)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 5) = S1.Cells(X, 6)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 6) = S1.Cells(X, 7)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 7) = S1.Cells(X, 8)
Sheets(CStr(S1.Cells(X, 1))).Cells(SATIR, 8) = S1.Cells(X, 9)
Sheets(CStr(S1.Cells(X, 1))).Cells.EntireColumn.AutoFit

Else

Set SY = Sheets.Add
SY.Move After:=Worksheets(Worksheets.Count)
SY.Name = S1.Cells(X, 1)
SY.Range("A1:H1").Value = S1.Range("B8:I8").Value
SY.Range("A2:H2").Value = S1.Range("B" & X & ":I" & X).Value
SY.Cells.EntireColumn.AutoFit
End If

End If
End If
End If
End If
End If
Next

Set S1 = Nothing

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Kodu aşağıdaki şekilde değiştirip denermisiniz.

Option Explicit
 
Sub SAYFALARA_DAĞIT()
    Dim S1 As Worksheet
    Dim SY As Worksheet
    Dim X As Long
    Dim SATIR As Long
    
    Set S1 = Sheets("ANALİZ")
    
    Application.ScreenUpdating = False
    
    For X = 1 To S1.Range("A65536").End(3).Row
        If S1.Cells(X, 1) <> "" Then
        If InStr(1, S1.Cells(X, 1), "İMKB") = 0 Then
        If InStr(1, S1.Cells(X, 1), "Yüksek") = 0 Then
        If InStr(1, S1.Cells(X, 1), "[") = 0 Then
        If Not IsNumeric(S1.Cells(X, 1)) Then
  
        If SAYFA(S1.Cells(X, 1)) Then
        
            Sheets(CStr(S1.Cells(X, 1))).Rows(2).Insert
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 1) = S1.Cells(X, 2)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 2) = S1.Cells(X, 3)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 3) = S1.Cells(X, 4)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 4) = S1.Cells(X, 5)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 5) = S1.Cells(X, 6)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 6) = S1.Cells(X, 7)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 7) = S1.Cells(X, 8)
            Sheets(CStr(S1.Cells(X, 1))).Cells(2, 8) = S1.Cells(X, 9)
            Sheets(CStr(S1.Cells(X, 1))).Cells.EntireColumn.AutoFit
    
        Else
    
            Set SY = Sheets.Add
            SY.Move After:=Worksheets(Worksheets.Count)
            SY.Name = S1.Cells(X, 1)
            SY.Range("A1:H1").Value = S1.Range("B8:I8").Value
            SY.Range("A2:H2").Value = S1.Range("B" & X & ":I" & X).Value
            SY.Cells.EntireColumn.AutoFit
        End If
        
        End If
        End If
        End If
        End If
        End If
    Next
    
    Set S1 = Nothing
    
    Sheets("ANA_SAYFA").Select
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Function SAYFA(SAYFAADI As String) As Boolean
    On Error Resume Next
    SAYFA = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function

 

[ali14]

Süper ellerine sağlık kardeşim iyi geceler forma katkın inan taktire şayan tabi benim kanaatim.