kapalı dosyada boş satırdan devam etmesi

Y

YABANIM

Katılım
28 Aralık 2005
Mesajlar
18
Excel Vers. ve Dili
EXCEL 2010
Merhaba;

Aşağıdaki kodun ilgili dosyayı açıp kayıt eden kısmında mevcut bilginin üzerine değişiklik yapan kısmını değişiklik yapmadan
boş satırdan devam etmesini sağlayarak kayıt edebilecek şekilde nasıl değiştiririm. Yardımcı olursanız sevinirim yeterli kod bilgim bulunmamaktadır


Sub DosyaAra()
Sayfa1.Range("AG1:AG5000").ClearContents
For i = 3 To Sayfa1.Range("A50000").End(xlUp).Row
'sayfa1.Cells(i,"A")
'Sayfa1.Range("A50000").End(xlUp).Row
dizin = Dir(ThisWorkbook.Path & "\")
varmi = "h"
Do While dizin <> ""
DoEvents
dosyaisim = Left(dizin, WorksheetFunction.Find(".", dizin) - 1)

If Sayfa1.Cells(i, "A") = dosyaisim Then
Set excel = Workbooks.Open(ThisWorkbook.Path & "\" & dizin)
sat = 2
varmi = "e"
For a = 3 To Sayfa1.Range("A50000").End(xlUp).Row
If Sayfa1.Cells(a, "A") = dosyaisim And Sayfa1.Cells(a, "AG") <> "*" Then

excel.Sheets("CB").Range("A" & sat) = Sayfa1.Cells(a, "F")
excel.Sheets("CB").Range("B" & sat) = Sayfa1.Cells(a, "J")
excel.Sheets("CB").Range("c" & sat) = Sayfa1.Cells(a, "R")
excel.Sheets("CB").Range("D" & sat) = Sayfa1.Cells(a, "A")
excel.Sheets("CB").Range("E" & sat) = Sayfa1.Cells(a, "S")
excel.Sheets("CB").Range("F" & sat) = Sayfa1.Cells(a, "Q")
excel.Sheets("CB").Range("G" & sat) = Sayfa1.Cells(a, "U")

excel.Sheets("CB").Range("H" & sat) = Sayfa1.Cells(a, "V")
excel.Sheets("CB").Range("I" & sat) = Sayfa1.Cells(a, "W")
excel.Sheets("CB").Range("J" & sat) = Sayfa1.Cells(a, "X")
excel.Sheets("CB").Range("K" & sat) = Sayfa1.Cells(a, "Y")
excel.Sheets("CB").Range("L" & sat) = Sayfa1.Cells(a, "Z")

Sayfa1.Cells(a, "AG") = "*"

sat = sat + 1
End If
Next a
excel.Save
excel.Close
Set excel = Nothing

End If

dizin = Dir()
Loop

sat = 2
If varmi = "h" Then

Set yeni = Workbooks.Add
'yeni.Sheets.Add
yeni.Sheets(1).Name = "CB"

yeni.Sheets("CB").Range("A1") = "MalzemeSistemKodu"
yeni.Sheets("CB").Range("b1") = "MalzemeAciklamasi"
yeni.Sheets("CB").Range("c1") = "Sınıf"
yeni.Sheets("CB").Range("d1") = "Musteri"
yeni.Sheets("CB").Range("e1") = "FiyatTuru"
yeni.Sheets("CB").Range("f1") = "TeklifTarihi"
yeni.Sheets("CB").Range("g1") = "TeklifFiyati"
yeni.Sheets("CB").Range("h1") = "FiyatBirimi"
yeni.Sheets("CB").Range("I1") = "İskonto Oranı"
yeni.Sheets("CB").Range("j1") = "BİRİM FİYAT"
yeni.Sheets("CB").Range("K1") = "Fiyat birimi"
yeni.Sheets("CB").Range("L1") = "Aciklama"


For a = 2 To Sayfa1.Range("A50000").End(xlUp).Row
If Sayfa1.Cells(i, "A") = Sayfa1.Cells(a, "A") And Sayfa1.Cells(a, "AG") <> "*" Then

yeni.Sheets("CB").Range("A" & sat) = Sayfa1.Cells(a, "F")
yeni.Sheets("CB").Range("B" & sat) = Sayfa1.Cells(a, "J")
yeni.Sheets("CB").Range("c" & sat) = Sayfa1.Cells(a, "R")
yeni.Sheets("CB").Range("D" & sat) = Sayfa1.Cells(a, "A")
yeni.Sheets("CB").Range("E" & sat) = Sayfa1.Cells(a, "S")
yeni.Sheets("CB").Range("F" & sat) = Sayfa1.Cells(a, "Q")
yeni.Sheets("CB").Range("G" & sat) = Sayfa1.Cells(a, "U")

yeni.Sheets("CB").Range("H" & sat) = Sayfa1.Cells(a, "V")
yeni.Sheets("CB").Range("I" & sat) = Sayfa1.Cells(a, "W")
yeni.Sheets("CB").Range("J" & sat) = Sayfa1.Cells(a, "X")
yeni.Sheets("CB").Range("K" & sat) = Sayfa1.Cells(a, "Y")
yeni.Sheets("CB").Range("L" & sat) = Sayfa1.Cells(a, "Z")

Sayfa1.Cells(a, "AG") = "*"
sat = sat + 1
End If
Next a
yeni.SaveAs ThisWorkbook.Path & "\" & Sayfa1.Cells(i, "A")
yeni.Close
Set yeni = Nothing
End If


Next i
End Sub
Sub test()
If varmi = "" Then
MsgBox Sayfa1.Cells(i, "A") & " " & dosyaisim
Set yeni = Workbooks.Add
'yeni.Sheets.Add
yeni.Sheets(1).Name = "CB"

For a = 3 To Sayfa1.Range("A50000").End(xlUp).Row
'For i = 2 To .Range("A" & Rows.Count).End(3).Row 'BENİM EKLEDİĞİM KOŞUL
If Sayfa1.Cells(a, "A") = dosyaisim And Sayfa1.Cells(a, "AG") <> "*" Then

yeni.Sheets("CB").Range("A" & sat) = Sayfa1.Cells(a, "F")
yeni.Sheets("CB").Range("B" & sat) = Sayfa1.Cells(a, "J")
yeni.Sheets("CB").Range("c" & sat) = Sayfa1.Cells(a, "R")
yeni.Sheets("CB").Range("D" & sat) = Sayfa1.Cells(a, "A")
yeni.Sheets("CB").Range("E" & sat) = Sayfa1.Cells(a, "S")
yeni.Sheets("CB").Range("F" & sat) = Sayfa1.Cells(a, "Q")
yeni.Sheets("CB").Range("G" & sat) = Sayfa1.Cells(a, "U")

yeni.Sheets("CB").Range("H" & sat) = Sayfa1.Cells(a, "V")
yeni.Sheets("CB").Range("I" & sat) = Sayfa1.Cells(a, "W")
yeni.Sheets("CB").Range("J" & sat) = Sayfa1.Cells(a, "X")
yeni.Sheets("CB").Range("K" & sat) = Sayfa1.Cells(a, "Y")
yeni.Sheets("CB").Range("L" & sat) = Sayfa1.Cells(a, "Z")

Sayfa1.Cells(a, "AG") = "*"
sat = sat + 1
End If
Next a
yeni.SaveAs ThisWorkbook.Path & "\" & dosyaisim
yeni.Close
Set yeni = Nothing
End If
End Sub
 
Y

YABANIM

Katılım
28 Aralık 2005
Mesajlar
18
Excel Vers. ve Dili
EXCEL 2010
Merhaba;

konu ile ilgili destek olabilecek bir arkadaşım varmı ? desteğinizi rica ederim
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,513
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Kod eklemek yerine dosyalarınızı paylaşırsanız yardım almanız daha da kolaylaşır.
 
Y

YABANIM

Katılım
28 Aralık 2005
Mesajlar
18
Excel Vers. ve Dili
EXCEL 2010
Korhan Bey merhaba;

Dosya ekleyemiyorum sanırsam.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Böyle cevap vermek zor herhalde hep ikinci satıra kayıt yapıyor öyle değilmi.

Rich (BB code): 
Sub DosyaAra()
Sayfa1.Range("AG1:AG5000").ClearContents
For i = 3 To Sayfa1.Range("A50000").End(xlUp).Row
'sayfa1.Cells(i,"A")
'Sayfa1.Range("A50000").End(xlUp).Row
dizin = Dir(ThisWorkbook.Path & "\")
varmi = "h"
Do While dizin <> ""
DoEvents
dosyaisim = Left(dizin, WorksheetFunction.Find(".", dizin) - 1)

If Sayfa1.Cells(i, "A") = dosyaisim Then
Set Excel = Workbooks.Open(ThisWorkbook.Path & "\" & dizin)
'sat = 2
sat = Excel.Sheets("CB").Cells(Rows.Count, "A").End(3).Row + 1

varmi = "e"
For a = 3 To Sayfa1.Range("A50000").End(xlUp).Row
If Sayfa1.Cells(a, "A") = dosyaisim And Sayfa1.Cells(a, "AG") <> "*" Then

Excel.Sheets("CB").Range("A" & sat) = Sayfa1.Cells(a, "F")
Excel.Sheets("CB").Range("B" & sat) = Sayfa1.Cells(a, "J")
Excel.Sheets("CB").Range("c" & sat) = Sayfa1.Cells(a, "R")
Excel.Sheets("CB").Range("D" & sat) = Sayfa1.Cells(a, "A")
Excel.Sheets("CB").Range("E" & sat) = Sayfa1.Cells(a, "S")
Excel.Sheets("CB").Range("F" & sat) = Sayfa1.Cells(a, "Q")
Excel.Sheets("CB").Range("G" & sat) = Sayfa1.Cells(a, "U")

Excel.Sheets("CB").Range("H" & sat) = Sayfa1.Cells(a, "V")
Excel.Sheets("CB").Range("I" & sat) = Sayfa1.Cells(a, "W")
Excel.Sheets("CB").Range("J" & sat) = Sayfa1.Cells(a, "X")
Excel.Sheets("CB").Range("K" & sat) = Sayfa1.Cells(a, "Y")
Excel.Sheets("CB").Range("L" & sat) = Sayfa1.Cells(a, "Z")

Sayfa1.Cells(a, "AG") = "*"

sat = sat + 1
End If
Next a
Excel.Save
Excel.Close
Set Excel = Nothing

End If

dizin = Dir()
Loop

'sat = 2
If varmi = "h" Then

Set yeni = Workbooks.Add
'yeni.Sheets.Add
yeni.Sheets(1).Name = "CB"

yeni.Sheets("CB").Range("A1") = "MalzemeSistemKodu"
yeni.Sheets("CB").Range("b1") = "MalzemeAciklamasi"
yeni.Sheets("CB").Range("c1") = "Sınıf"
yeni.Sheets("CB").Range("d1") = "Musteri"
yeni.Sheets("CB").Range("e1") = "FiyatTuru"
yeni.Sheets("CB").Range("f1") = "TeklifTarihi"
yeni.Sheets("CB").Range("g1") = "TeklifFiyati"
yeni.Sheets("CB").Range("h1") = "FiyatBirimi"
yeni.Sheets("CB").Range("I1") = "İskonto Oranı"
yeni.Sheets("CB").Range("j1") = "BİRİM FİYAT"
yeni.Sheets("CB").Range("K1") = "Fiyat birimi"
yeni.Sheets("CB").Range("L1") = "Aciklama"

sat = yeni.Sheets("CB").Cells(Rows.Count, "A").End(3).Row + 1

For a = 2 To Sayfa1.Range("A50000").End(xlUp).Row
If Sayfa1.Cells(i, "A") = Sayfa1.Cells(a, "A") And Sayfa1.Cells(a, "AG") <> "*" Then

yeni.Sheets("CB").Range("A" & sat) = Sayfa1.Cells(a, "F")
yeni.Sheets("CB").Range("B" & sat) = Sayfa1.Cells(a, "J")
yeni.Sheets("CB").Range("c" & sat) = Sayfa1.Cells(a, "R")
yeni.Sheets("CB").Range("D" & sat) = Sayfa1.Cells(a, "A")
yeni.Sheets("CB").Range("E" & sat) = Sayfa1.Cells(a, "S")
yeni.Sheets("CB").Range("F" & sat) = Sayfa1.Cells(a, "Q")
yeni.Sheets("CB").Range("G" & sat) = Sayfa1.Cells(a, "U")

yeni.Sheets("CB").Range("H" & sat) = Sayfa1.Cells(a, "V")
yeni.Sheets("CB").Range("I" & sat) = Sayfa1.Cells(a, "W")
yeni.Sheets("CB").Range("J" & sat) = Sayfa1.Cells(a, "X")
yeni.Sheets("CB").Range("K" & sat) = Sayfa1.Cells(a, "Y")
yeni.Sheets("CB").Range("L" & sat) = Sayfa1.Cells(a, "Z")

Sayfa1.Cells(a, "AG") = "*"
sat = sat + 1
End If
Next a
yeni.SaveAs ThisWorkbook.Path & "\" & Sayfa1.Cells(i, "A")
yeni.Close
Set yeni = Nothing
End If


Next i
End Sub
Sub test()
If varmi = "" Then
MsgBox Sayfa1.Cells(i, "A") & " " & dosyaisim
Set yeni = Workbooks.Add
'yeni.Sheets.Add
yeni.Sheets(1).Name = "CB"

sat = yeni.Sheets("CB").Cells(Rows.Count, "A").End(3).Row + 1
For a = 3 To Sayfa1.Range("A50000").End(xlUp).Row
'For i = 2 To .Range("A" & Rows.Count).End(3).Row 'BENİM EKLEDİĞİM KOŞUL
If Sayfa1.Cells(a, "A") = dosyaisim And Sayfa1.Cells(a, "AG") <> "*" Then

yeni.Sheets("CB").Range("A" & sat) = Sayfa1.Cells(a, "F")
yeni.Sheets("CB").Range("B" & sat) = Sayfa1.Cells(a, "J")
yeni.Sheets("CB").Range("c" & sat) = Sayfa1.Cells(a, "R")
yeni.Sheets("CB").Range("D" & sat) = Sayfa1.Cells(a, "A")
yeni.Sheets("CB").Range("E" & sat) = Sayfa1.Cells(a, "S")
yeni.Sheets("CB").Range("F" & sat) = Sayfa1.Cells(a, "Q")
yeni.Sheets("CB").Range("G" & sat) = Sayfa1.Cells(a, "U")

yeni.Sheets("CB").Range("H" & sat) = Sayfa1.Cells(a, "V")
yeni.Sheets("CB").Range("I" & sat) = Sayfa1.Cells(a, "W")
yeni.Sheets("CB").Range("J" & sat) = Sayfa1.Cells(a, "X")
yeni.Sheets("CB").Range("K" & sat) = Sayfa1.Cells(a, "Y")
yeni.Sheets("CB").Range("L" & sat) = Sayfa1.Cells(a, "Z")

Sayfa1.Cells(a, "AG") = "*"
sat = sat + 1
End If
Next a
yeni.SaveAs ThisWorkbook.Path & "\" & dosyaisim
yeni.Close
Set yeni = Nothing
End If
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,513
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Paylaşım sitelerine yükleyip link verebilirsiniz.

Yapmak istediğiniz işlemi de eklediğiniz dosyalar üzerinden açıklayınız.
 
Y

YABANIM

Katılım
28 Aralık 2005
Mesajlar
18
Excel Vers. ve Dili
EXCEL 2010
Halit Bey merhaba;
aynı satırlarda kodu bulup onun karşısındaki bilgileri güncelliyor .Oysa ben yeni kayıtları boş olan satırdan devam etmesini istiyorum
Desteğiniz için teşekkür ederim
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
YABANIM' Alıntı:
Halit Bey merhaba;
aynı satırlarda kodu bulup onun karşısındaki bilgileri güncelliyor .Oysa ben yeni kayıtları boş olan satırdan devam etmesini istiyorum
Desteğiniz için teşekkür ederim
Genişletmek için tıkla ...
5 nolu mesajımda kırmızı yerleri eklemiştim siz kodlarınıza bu ilaveleri yaptınızmı
eğer yaptıysanız düzelmediyse örnek dosyalarınızı ekleyiniz.
 
Y

YABANIM

Katılım
28 Aralık 2005
Mesajlar
18
Excel Vers. ve Dili
EXCEL 2010
Halit Bey merhaba;
Mesajınızı ineliyorum .Desteğiniz için teşekkürler konu ile ilgili dönüş yapacağım
 
Y

YABANIM

Katılım
28 Aralık 2005
Mesajlar
18
Excel Vers. ve Dili
EXCEL 2010
Halit Bey merhaba;

MsgBox Sayfa1.Cells(i, "A") & " " & dosyaisim hatası verdi
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
1. nolu mesajdaki sorunuz ile şimdiki soru çok farklı oldu
daha önce çalışan dosyanın kayıt için sadece satır numarası değişince söylediğiniz hata alınmazki demekki kodlarınız hiç çalışmıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst