Kopyalama Makrosu hakkında

[northcyprus]

Herkese selamlar,

Yapmak istediğim şey sayfa 2 nin B11 inden B kolonundaki X e kadar olan bölümde sayfa 1 in B2 sinden B15 ine kadar olan bölümün arasındaki hücrelerde ayni isim varsa sayfa 2 deki isimerin bulunduğu satırdaki A ve B hücrelerini kopyalayıp Sayfa 3 ün A2 sinden başlayarak yapıştırmak istiyorum


yardımlarınızı bekliyorum..

teşekürler.

 

[Emir Hüseyin Çoban]

. . .

Büyük, kapsamlı bir tablo.
PRİNT sayfasındaki listeye kadar, tablodaki kodlamalar oluşturuyor mu ?

. . .

 

[northcyprus]

evet oluşturuluyor sadece print sayfasına ADİSYONMASA1 sayfasındaki X e kadar olanların aynısı MENÜ sayfasının B2 sinden B15 ine kadar Var ise ASİSYONMASA1 Sayfasındaki isimerin bulunduğu satırdaki A ve B hücrelerini kopyalayıp Print Sayfasına Almak istiyorum ama bir türlü başarılı olamadım başarılı olamadım

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Dim i, S2sonsat, S1sonsat
Set S1 = Sheets("MENÜ")
Set S2 = Sheets("PRİNT")
S2sonsat = S2.[B65536].End(3).Row
S1sonsat = S1.[B65536].End(3).Row

For i = S2sonsat To 2 Step -1
If WorksheetFunction.CountIf(S1.Range("B20:B" & S1sonsat), S2.Cells(i, "B")) > 0 Then
Rows(i).Delete
Else: End If
Next i

Set S1 = Nothing
Set S2 = Nothing
S2sonsat = Empty
S1sonsat = Empty
i = Empty

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .

 

[northcyprus]

sayın hocam verdiginiz kodu gönder butonua ekledim fakat MsgBox ta Bitti Diyor fakat hiçbişey çalışmıyor...

hocam Mutfaklist Diye bir LİSTBOX var ya oraya gönder butonuna tıkladığım zaman sadece ADİSYON1 LİSTBOX un içindeki Kebabları Yani MENÜ sayfasındaki B2 Den B15 e Kadar olan Bölümdekileri göndersin.

dosyayı tekrar ekledim saygılarımla

 

[Emir Hüseyin Çoban]

. . .

Yukarıda verdiğim kodlar meşrubat ürünlerini listeden siler. Yani gönder butonunda olan kodlarınızın sonuna ilave olarak ekleyin.

. . .

 

[Emir Hüseyin Çoban]

evet oluşturuluyor sadece print sayfasına ADİSYONMASA1 sayfasındaki X e kadar olanların aynısı MENÜ sayfasının B2 sinden B15 ine kadar Var ise ASİSYONMASA1 Sayfasındaki isimerin bulunduğu satırdaki A ve B hücrelerini kopyalayıp Print Sayfasına Almak istiyorum ama bir türlü başarılı olamadım başarılı olamadım

. . .

Sub KOD_2()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Dim i, S2sonsat, S1sonsat
Set S1 = Sheets("MENÜ")
Set S2 = Sheets("ADİSYONMASA1")
Set S3 = Sheets("PRİNT")
s3_sat = 2
s2_son = S2.[b65536].End(3).Row - 1

For i = 11 To s2_son
For a = 2 To 15
If S2.Cells(i, "B") = S1.Cells(a, "b") Then

S3.Cells(s3_sat, "a") = S2.Cells(i, "a")
S3.Cells(s3_sat, "b") = S2.Cells(i, "b")
s3_sat = s3_sat + 1

Else: End If
Next a
Next i

Set S1 = Nothing
Set S3 = Nothing
Set S2 = Nothing
s3_sat = Empty
s2_son = Empty
i = Empty
a = Empty

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .

 

[northcyprus]

. . .

Büyük, kapsamlı bir tablo.
PRİNT sayfasındaki listeye kadar, tablodaki kodlamalar oluşturuyor mu ?

. . .

sayın hocam bu sorunuzu yanlış anlamışım kodu ekleyince farkettim, çünkü satırların yerleri değiştiğinde çalışmayacak..


Private Sub GÖNDER1_Click()
Sheets("ADİSYONMASA1").Select
Range("A66").Select
Selection.Copy
Sheets("PRİNT").Select
Range("A11").Select
ActiveSheet.Paste
Sheets("ADİSYONMASA1").Select
Range("A11:C14,A18:C20").Select
Range("A18").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("PRİNT").Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A11").Select
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A250").Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A11").Select
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Dim i, S2sonsat, S1sonsat
Set S1 = Sheets("MENÜ")
Set S2 = Sheets("PRİNT")
S2sonsat = S2.[B65536].End(3).Row
S1sonsat = S1.[B65536].End(3).Row

For i = S2sonsat To 2 Step -1
If WorksheetFunction.CountIf(S1.Range("B20:B" & S1sonsat), S2.Cells(i, "B")) > 0 Then
Rows(i).Delete
Else: End If
Next i

Set S1 = Nothing
Set S2 = Nothing
S2sonsat = Empty
S1sonsat = Empty
i = Empty

Application.ScreenUpdating = True
MsgBox " B İ T T İ "

End Sub