- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,878
- Excel Vers. ve Dili
- 2003 excell türkçe
ve
2007 excell türkçe
Merhaba.
Halit Bey. 9. nolu mesajda Kod "Ok" kontrollerini kapalılarda yapıyor.
Kapalıları açıp kontrol etmek verileri elle yazmakla eşdeğer olur hemen hemen
Makromuz da cazibesini yitirir bu durumda.
Ben kendimce şu şekilde olabilir diye düşünüyorum ama koda dökemiyorum :
Veri aktarmak için ilk önce açık dosya ile kapalı dosyalarda D ve F sütunlarının eşitliğini arıyoruz
D ve F sütununun eşitliği sağlandığında ondan sonra aktarma işlemlerine başlıyoruz.
D ve F sütununun her iki dosyada da (kapalı ve açık) eşitliği sağlandığı durumda;
M sütunu kontrol edilse M sütunu dolu ise ( "Ok" yazıyorsa ) döngü sonlansa. Boş ise
ondan sonra aktarma işlemine devam etse...
Kodlara bu şekilde hükmek doğru değil kod döngüsü birinci dosyayı açıyor ve kontrol ediyor gerekli şartlar oluşunca verileri aktarıyor ve ilk aktarımdan sonra duruyor ve anasayfada aktarılan hücreyi işaretliyor döngü devam ediyor ikinci dosyayı açıyor anasayfadaki işaretli kısmı pas geçiyor bu düzen ne kadar dosya varsa böyle devam edip gidiyor.
Kayıt dosyası birden fazla olursa bu düzen böyle devam eder gider
Her dosyaya ait ya sütun ayrı olacak yada işaretleri iç içe yazacak yada ok işaretinden vaz geçilecek.
Birde bunu dene bakalım buda başka bir çözüm.
Her işaret bir dosyadaki satırı ifade etmektedir.
örnek ok ok =iki satır
ok ok ok= üç satır
Kod:
Sub verikayityap()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
On Error Resume Next
For Each dosya In fs
If ThisWorkbook.Name <> dosya.Name Then
Set wb = Workbooks.Open(dosya)
say = say + 1
For i = 7 To ThisWorkbook.Worksheets("liste").Cells(Rows.Count, "D").End(3).Row
aranan1 = ThisWorkbook.Worksheets("liste").Cells(i, "D").Value
aranan2 = ThisWorkbook.Worksheets("liste").Cells(i, "f").Value
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan4 = ThisWorkbook.Worksheets("liste").Cells(i, "ı").Value
aranan5 = ThisWorkbook.Worksheets("liste").Cells(i, "k").Value
aranan6 = ThisWorkbook.Worksheets("liste").Cells(i, "l").Value
aranan7 = Mid(ThisWorkbook.Worksheets("liste").Cells(i, "m").Value, say, 3)
If Trim(aranan7) <> "Ok" Then
For j = 7 To Sheets("Data").Cells(Rows.Count, "D").End(3).Row
bulunan1 = Sheets("Data").Cells(j, "D").Value
bulunan2 = Sheets("Data").Cells(j, "f").Value
bulunan3 = Sheets("Data").Cells(j, "h").Value
If aranan1 = bulunan1 Then
If aranan2 = bulunan2 Then
If bulunan3 = "" Then
Sheets("Data").Cells(j, "h").Value = aranan3
Sheets("Data").Cells(j, "ı").Value = aranan4
Sheets("Data").Cells(j, "k").Value = aranan5
Sheets("Data").Cells(j, "l").Value = aranan6
ThisWorkbook.Worksheets("liste").Cells(i, "m").Value = "Ok " & ThisWorkbook.Worksheets("liste").Cells(i, "m").Value
Exit For
End If
End If
End If
Next j
End If
Next i
ActiveWorkbook.Save
ActiveWindow.Close
End If
Dir dosya
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub