• DİKKAT

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

Makroyla veri aktarma

E

eseseski

Katılım
20 Şubat 2012
Mesajlar
150
Excel Vers. ve Dili
2007 türkçe
A B C
Mesai. Nöbet
01eylül. Ali. Selami
02eylül. Veli. Ali
03eylül. Selami. Veli
Bu yukarıdaki sayfadaki isimlerin mesai ve nöbetlerini başka bir sayfada isimlerin karşılıklarına aşağıdaki gibi nasıl yazdırabiliriz

A. B. C. D
01eylül. 02eylül. 03eylül
Ali. M. N
Veli. M. N
Selami. N. M
 
Son düzenleme:
Sub transpoze()

Sheets("sayfa1").Range("A4:C9").Select
Selection.Copy
Sheets("sayfa2").Range("G5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
End Sub

Buna benzer bir şey mi kasdettiniz ? Doğru ise sayfa üzerinde düzenlemeleri kodlara uyarlayınız .

http://s9.dosya.tc/server/619716/ters_cevir.rar.html
 
hayır cems hocam bir önceki mesajımda paylaştığım imaj dosyalarında ki gibi aktarılacak
 
Son düzenleme:
Merhaba.

Cevabımın altında bulunan İMZA bölümündeki açıklamaları okuyarak
gerçek belgenizle aynı yapıda bir örnek belge yükleyip onun üzerinden gitmekte yarar var diye düşünüyorum.

Resim yerine örnek belge yüklemeniz sonuca ulaşmanızı kolaylaştıracaktır.
Bu haliyle verilecek kod/formül cevaplarının gerçek belgenize uyarlanması aşamasında sorun yaşayacağınız kaçınılmaz gibi.

Ayrıca mevcut bir benzersiz isim listeniz de vardır sanırım.
.
 
Merhaba.

Bu cevaptaki kod yerine 12 numaralı cevaptaki kod'u kullanın.

Buradaki kod'u sildim.
.
 
Son düzenleme:
eseseski' Alıntı:
Teşekür ederim hocam
Genişletmek için tıkla ...
Estağfurullah, ihtiyaç görüldüyse mesele yok.

Bu arada kod'da fazlalık olan iki satırı silip, bu satırları Next satırından önceki mavi satırda,
olması gereken yere akladim (yani kod'da temizlik yapmış oldum).

Sayfayı yenileyerek önceki cevabıma tekrar bakınız.

Kod'un çalışmasında bir değişiklik yok maksat sadece kod düzenindeki sadelik.
.
 
sayın Ömer hocam gönderdiğiniz kodun uygulamasını yeni deneyebildim.
kod 'N' harfini yazmıyor.Ayrıca ben puantaj listesindeki isimler sabit kalsın ve çizelge sayfasına isimleri girdikçe karşılığına 'M' ve 'N' yazsın istiyorum.
sizin yazmış olduğunuz kodda çizelgeye isim girdikçe puantajda isim ve karşılığını yazıyor.
bir de aşağıda paylaştığım dosyayı genişlettim ve kodu uygulamaya çalıştım fakat beceremedim
siz ve sizin gibi ilgili arkadaşlar bakabilirse memnun olurum saygılarımla

http://s9.dosya.tc/server/c3xdv2/CALISMA.zip.html
 
Son düzenleme:
Merhaba.

Belgenizin yapısı değişmiş önceki cevabımdaki kod'u şimdi sildim. Siz de belgenizde bulunan önceki kod'u silin.

Belgeniz açıkken ALT+F11 tuşlarına basarak VBA ekranını açın, VBA ekranında üst taraftaki manülerden INSERT -> MODULE'yi seçin,
aşağıdaki kod'u sağ taraftaki boş alana yapıştırın ve F5 tuşuna basın. Kod çalışacak ve istediğiniz işlemi yapacaktır.

Ayrıca sayfalardan birine bir düğme/şekil/metin kutusu ekleyin ve bu düğme/şekil/metin kutusu'ra sağ tıklayıp MAKRO ATA'yı seçin,
açılan küçük ekranda (alt taraftaki seçeneklerden "BU ÇALIŞMA KİTABI"nı seçip) üst taraftaki kısımdan da "mesai_aktar"ı seçip işlemi onaylayın.

Artık kod bu düğme/şekil/metin kutusuna tıkladığınızda çalışarak işlemi yapacaktır.

Not:
-- Kod çizelge sayfası 8'inci satırdaki mesai/nöbet kelimelerine göre işlem yapmaktadır.
-- Kod'daki kırmızı kısım, çizelge sayfasında olup, puantaj sayfasında olmayan isme rastlanırsa
puantaj sayfasındaki isim listesinin sonuna eklemektedir. Böyle bir durum olmayacaksa kırmızı kısmı silebilirsiniz.
.
Kod: 
[FONT="Arial Narrow"][B]Sub mesai_aktar()[/B]
Dim brn As Range
Set s1 = Sheets("çizelge"): Set s2 = Sheets("puantaj")
s2.Range("C8:AG" & s2.[B65536].End(3).Row).ClearContents
s1.Range("A10:A" & s1.[A65536].End(3).Row).Copy
s2.[C7].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True
s2.Range("C7:AG7").NumberFormat = "dd.mm"
For Each brn In s1.Range("B10:L40")
    If brn.Value <> "" Then
[COLOR="Red"]    If WorksheetFunction.CountIf(s2.Range("B:B"), brn.Value) = 0 Then _
        s2.Cells([B65536].End(3).Row + 1, 2) = brn.Value[/COLOR]
        If s1.Cells(8, brn.Column) = "[B][COLOR="blue"]mesai[/COLOR][/B]" Then değer = "M"
        If s1.Cells(8, brn.Column) = "[B][COLOR="blue"]nöbet[/COLOR][/B]" Then değer = "N"
        s2.Cells(WorksheetFunction.Match(brn.Value, s2.Range("B:B"), 0), brn.Row - 7) = değer
    End If
Next brn
s2.Columns.AutoFit: s2.Range("C:AG").HorizontalAlignment = xlCenter
s2.Activate: s2.[A7].Activate: MsgBox "İŞLEM TAMAM..."
[B]End Sub[/B][/FONT]
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst