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
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