• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

makro ile veri aktarımı

Başlığınız genel olmuş.

Başlığınızı açık bir dille ifade etmelisiniz.

Üyeler dosyanızı indirmeden de ne talep ettiğinizi başlığınızı okuyarak anlayabilmelidir. Bu şekilde düzenlemelisiniz.
 
makroyu ayarladım ancak yapamadığım şeyler var yardım edermisiniz lütfen ..
ARKADAŞLAR ŞÖYLE ÖZETLİYİM:

B SÜTUNUNA GÖRE HANHİ HÜCREYE TIKLARSAM ONUN SAYFASINA ATIYOR SATIRI ANCAK BURDA KALIYOR BEN BURDANDA SİLİNSİN İSTİYORUM AYRICA NEREYE TIKLASAM FARK ETMİYOR BUNU SADECE I SÜTUNUNNA GÖRE AYARLAYABİLİRMİYİZ.

Download link:

http://s9.dosya.tc/server2/94pbt7/son_....rar.html

I SÜTUNUNU SADECE KÜÇÜK HARF YAZACAK ŞEKİLDE Bİ MAKRO MÜMKÜNMÜDÜR

B SÜTUNUNUN AYLARINI ELLE YAZIYORUM A DAN AAAA ŞEKLİNDE ALDIĞIMDA KABUL ETMİYOR

YARDIMLARINIZI ESİRGEMEZSENİZ SEWVİNİRİM
 
cvp

drykcktl' Alıntı:
makroyu ayarladım ancak yapamadığım şeyler var yardım edermisiniz lütfen ..
ARKADAŞLAR ŞÖYLE ÖZETLİYİM:

B SÜTUNUNA GÖRE HANHİ HÜCREYE TIKLARSAM ONUN SAYFASINA ATIYOR SATIRI ANCAK BURDA KALIYOR BEN BURDANDA SİLİNSİN İSTİYORUM AYRICA NEREYE TIKLASAM FARK ETMİYOR BUNU SADECE I SÜTUNUNNA GÖRE AYARLAYABİLİRMİYİZ.

Download link:

http://s9.dosya.tc/server2/94pbt7/son_....rar.html

I SÜTUNUNU SADECE KÜÇÜK HARF YAZACAK ŞEKİLDE Bİ MAKRO MÜMKÜNMÜDÜR

B SÜTUNUNUN AYLARINI ELLE YAZIYORUM A DAN AAAA ŞEKLİNDE ALDIĞIMDA KABUL ETMİYOR

YARDIMLARINIZI ESİRGEMEZSENİZ SEWVİNİRİM
Genişletmek için tıkla ...



yardımcı olabilecek kimse yokmu arkadaşlar
 
B3 hücresine eklerseniz A3 hücresine tarih girince ay olarak yazar.
Kod: 
=BÜYÜKHARF(METNEÇEVİR(A1;"aaaa"))

Aktarma için "GİRİŞ SAYFASI" Kod bölümüne ekleyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("GİRİŞ SAYFASI")
Application.ScreenUpdating = False
If Intersect(Target, Range("I2:I500")) Is Nothing Then Exit Sub
For i = S1.[B65536].End(3).Row To 3 Step -1
    Sayfa = Cells(i, "B")
      If Sayfa = "" Then GoTo 10
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    Set s2 = Sheets(Sayfa)
   If WorksheetFunction.CountIf(s2.Range("C2:C" & s2.Range("A" & Rows.Count).End(3).Row), S1.Cells(i, 3)) < 1 Then
    S1.Range("A1:P2").Copy s2.Range("A1")
    S1.Range("A" & i & ":P" & i).Copy s2.Range("A" & _
    s2.[A65536].End(3).Row + 1)
    s2.Range("A:P").EntireColumn.AutoFit
S1.Range("A" & i & ":P" & i).ClearContentselse
End If
S1.Range("A" & i & ":P" & i).ClearContents
10: Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function
 
olmadı

vardar07' Alıntı:
B3 hücresine eklerseniz A3 hücresine tarih girince ay olarak yazar.
Kod: 
=BÜYÜKHARF(METNEÇEVİR(A1;"aaaa"))

Aktarma için "GİRİŞ SAYFASI" Kod bölümüne ekleyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("GİRİŞ SAYFASI")
Application.ScreenUpdating = False
If Intersect(Target, Range("I2:I500")) Is Nothing Then Exit Sub
For i = S1.[B65536].End(3).Row To 3 Step -1
    Sayfa = Cells(i, "B")
      If Sayfa = "" Then GoTo 10
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    Set s2 = Sheets(Sayfa)
   If WorksheetFunction.CountIf(s2.Range("C2:C" & s2.Range("A" & Rows.Count).End(3).Row), S1.Cells(i, 3)) < 1 Then
    S1.Range("A1:P2").Copy s2.Range("A1")
    S1.Range("A" & i & ":P" & i).Copy s2.Range("A" & _
    s2.[A65536].End(3).Row + 1)
    s2.Range("A:P").EntireColumn.AutoFit
S1.Range("A" & i & ":P" & i).ClearContentselse
End If
S1.Range("A" & i & ":P" & i).ClearContents
10: Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function
Genişletmek için tıkla ...


sayın vardar yardımınıza teşekkürederim ancak verdiğiniz kodla denediğimde ekteki dosya gibi oldu..benim istediğim sadece ı sütununa tıkladığımda o satır aktarılsın ve giriş sayfasından silinsin..

Dosyanız, is_takip_listesi_-_Kopya.rar yüklendi!
Download link:

http://s9.dosya.tc/server2/p7mhdq/is_takip_listesi_-_Kopya.rar.html
 
Komple değiştirip deneyiniz.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("GİRİŞ SAYFASI")
Application.ScreenUpdating = False
If Intersect(Target, Range("I2:I500")) Is Nothing Then Exit Sub
  a = Target.Row
    Sayfa = Cells(a, "B")
              If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    Set s2 = Sheets(Sayfa)
   If WorksheetFunction.CountIf(s2.Range("C2:C" & s2.Range("A" & Rows.Count).End(3).Row), S1.Cells(a, 3)) < 1 Then
    S1.Range("A1:P2").Copy s2.Range("A1")
    S1.Range("A" & a & ":P" & a).Copy s2.Range("A" & _
    s2.[A65536].End(3).Row + 1)
    s2.Range("A:P").EntireColumn.AutoFit
S1.Range("A" & a & ":P" & a).Delete Shift:=xlUp
End If
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub
Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function
 
tşk

vardar07' Alıntı:
Komple değiştirip deneyiniz.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("GİRİŞ SAYFASI")
Application.ScreenUpdating = False
If Intersect(Target, Range("I2:I500")) Is Nothing Then Exit Sub
  a = Target.Row
    Sayfa = Cells(a, "B")
              If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    Set s2 = Sheets(Sayfa)
   If WorksheetFunction.CountIf(s2.Range("C2:C" & s2.Range("A" & Rows.Count).End(3).Row), S1.Cells(a, 3)) < 1 Then
    S1.Range("A1:P2").Copy s2.Range("A1")
    S1.Range("A" & a & ":P" & a).Copy s2.Range("A" & _
    s2.[A65536].End(3).Row + 1)
    s2.Range("A:P").EntireColumn.AutoFit
S1.Range("A" & a & ":P" & a).Delete Shift:=xlUp
End If
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub
Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function
Genişletmek için tıkla ...


ellerinize sağlık tam istediğim gibi olmuş nekadar teşekkür etsem az ..sizden son bir ricam olacak h sütununu sadece küçük haft yazacak şekilde yapmam mümkünmü
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst