• DİKKAT

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

Makroda hata mesajı

A

akmes

Katılım
27 Mayıs 2010
Mesajlar
527
Excel Vers. ve Dili
Excel 2003 Turkçe
Üstadım kolay gelsin,aşağıda yazılı makroyu çalıştırırken renkli yazdığım yer hata veriyor.Bir bakmanız mümkün mü acaba?

Sub hepsi()

Dim lastrow As Long
Dim rng As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim iStr As Integer
Dim iBul As Integer
Dim sAdr As String
Set sh1 = Worksheets("Dekon Rapor")
Set sh2 = Worksheets("Süzme")
sh2.Cells.Clear
sh1.Range("A2:H2").Copy sh2.Range("A1:H1")
Set rng = sh1.Columns(1).Find("Kayıt Sayısı", lookat:=xlWhole)
If Not rng Is Nothing Then
iStr = 2
sAdr = rng.Address
iBul = rng.Row
Do

If sh1.Range("A" & iBul - 1) <> "Fiş No" Then

sh1.Range("A" & iBul - 1 & ":H" & iBul - 1).Copy sh2.Range("A" & iStr & ":H" & iStr)
sh2.Range("D" & iStr) = sh2.Range("D" & iStr) - sh1.Range("D" & iBul - 2)

End If

Set rng = sh1.Columns(1).FindNext(rng)

iStr = iStr + 1: iBul = rng.Row

Loop Until rng Is Nothing Or sAdr = rng.Address
End If

Set rng = Nothing
Set sh1 = Nothing
Set sh2 = Nothing

Set s1 = Sheets("Süzme")
Set s2 = Sheets("Sayfa1")
s2.Range("A2:h65536").ClearContents
a = Array(1, 2, 3, 4, 5, 6, 7, 8)
sat = 1
For x = 2 To [a65536].End(3).Row
If Cells(x, 2) > 0 Then
sat = sat + 1
For y = 1 To 7
s2.Cells(sat, y) = s1.Cells(x, a(y - 1))
Next
End If
Next x
a = Array(1, 2, 3, 4, 5, 6, 7, 8)
For y = 0 To 2

Sheets("Sayfa1").Range("A2:ı65536").Sort Sheets("Sayfa1").Range("ı2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A2:G65536").ClearContents
a = Array(13, 14, 15, 16, 17, 18, 19)
sat = 1
For x = 2 To [a65536].End(3).Row
If Cells(x, 14) > 0 Then
sat = sat + 1
For y = 1 To 7
s2.Cells(sat, y) = s1.Cells(x, a(y - 1))
Next
End If
Next x
a = Array(13, 14, 15, 16, 17, 18, 19)
For y = 0 To 2
Next
End Sub
 
Selamlar,

Sn. akmes kodunuzda ilk bakışta hata verecek bir durum gözükmüyor. Örnek dosyanızı eklerseniz inceleme fırsatımız olabilir.
 
kırmızı yazan yerde eksiklik var

mavi yazan yerler bir işlem yapmıyor fazlalık var

]
 
Halit hocam; sizin yazdığınızı denedim sayfa2 ye veri aktarmıyor.Ben makroları sırası ile denediğimde son sayfaya veri aktarıyor.Hepsi makrosunu tıkladığımda hata veriyor.Ekte konu ile ilgili excel dosya örneğini yolluyorum.İlginiz için teşekkür ederim
 

Ekli dosyalar

deneme1 ile dene makrolarını hangi sayfada çalıştırdığırız zaman düzgün çalışıyor
buradaki kodların başını sayfaların adlarını getirmek gerekiyor.
 
eklediklerimi kırmız ile belirttim.

Sub hepsi()
Dim lastrow As Long
Dim rng As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim iStr As Integer
Dim iBul As Integer
Dim sAdr As String
Set sh1 = Worksheets("Dekon Rapor")
Set sh2 = Worksheets("Süzme")
sh2.Cells.Clear
sh1.Range("A2:H2").Copy sh2.Range("A1:H1")
Set rng = sh1.Columns(1).Find("Kayıt Sayısı", lookat:=xlWhole)
If Not rng Is Nothing Then
iStr = 2
sAdr = rng.Address
iBul = rng.Row
Do

If sh1.Range("A" & iBul - 1) <> "Fiş No" Then

sh1.Range("A" & iBul - 1 & ":H" & iBul - 1).Copy sh2.Range("A" & iStr & ":H" & iStr)
sh2.Range("D" & iStr) = sh2.Range("D" & iStr) - sh1.Range("D" & iBul - 2)

End If

Set rng = sh1.Columns(1).FindNext(rng)

iStr = iStr + 1: iBul = rng.Row

Loop Until rng Is Nothing Or sAdr = rng.Address
End If
Set rng = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Set s1 = Sheets("Süzme")
Set s2 = Sheets("Sayfa1")
s2.Range("A2:h65536").ClearContents
a = Array(1, 2, 3, 4, 5, 6, 7, 8)
sat = 1
For x = 2 To s1.[a65536].End(3).Row
If s1.Cells(x, 2) > 0 Then
sat = sat + 1
For y = 1 To 7
s2.Cells(sat, y) = s1.Cells(x, a(y - 1))
Next
End If
Next x
Sheets("Sayfa1").Range("A2:ı65536").Sort Sheets("Sayfa1").Range("ı2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A2:G65536").ClearContents
a = Array(13, 14, 15, 16, 17, 18, 19)
sat = 1
For x = 2 To s1.[a65536].End(3).Row
If s1.Cells(x, 14) > 0 Then
sat = sat + 1
For y = 1 To 7
s2.Cells(sat, y) = s1.Cells(x, a(y - 1))
Next
End If
Next x
End Sub
Genişletmek için tıkla ...
 
dosyanızın formatıda farklı siz en iyisi dozyanızı oçın farklı kayıtet seçeneğini seçin Microsolf Excel 97-200 ¾ 5.0/95 çalışma kitabını seçin ve kayıt yapın dosyanızın formatı değişsin.
 
Halit hocam emeğinize sağlık.Kırmızı renkli kod eklemelerini yaptıktan sonra çalıştı.Çok teşekkür ederim.
 
merhaba

ekteki macroyu çalıştıramıyorum.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
If Target.Column <> 1 Or Target.Value = "" Then Exit Sub
On Error GoTo Devam

Sheets(Target.Text).Select
MsgBox "BU ISIMDE BIR SAYFA MEVCUTTUR.", vbCritical
Sheets("ABDICA").Select
Target.Select
Application.ScreenUpdating = True
Exit Sub

Devam:
Sheets("SABLON").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Target.Text
Sheets("ABDICA").Select
Range("A2:A65536").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("A2").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub
 
sibelkorkut' Alıntı:
merhaba

ekteki macroyu çalıştıramıyorum.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
If Target.Column <> 1 Or Target.Value = "" Then Exit Sub
On Error GoTo Devam

Sheets(Target.Text).Select
MsgBox "BU ISIMDE BIR SAYFA MEVCUTTUR.", vbCritical
Sheets("ABDICA").Select
Target.Select
Application.ScreenUpdating = True
Exit Sub

Devam:
Sheets("SABLON").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Target.Text
Sheets("ABDICA").Select
Range("A2:A65536").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("A2").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...

sorunuzu yeni bir konu altında örnek dosyanızı ekliyerek açınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst