Arkadaşlar aşağıdaki kodda dışarında bir dosyadan aldığım şube numarasını mevcut exceldeki Şubeler sayfasında önce buldurdum. İlk ? isaretinin bulunduğu satırda Şube kodunun bulunduğu satırı doğru buluyor.
Sonra bulduğu satır numarasının ikinci sütünunda aynı şubenin adı var. İkinci soru işaretinde o adı sayfaa değişkenine atamak istiyorum. Yani şube kodunu bulduğu satırın ikinci sütünundan şube adını öğrenim "sayfaa" değişkenine atayacak.. Burada kod çalışmıyor. Sayfaa değişkeni boş geliyor.
Son aşamada her şube için mevcut excelde sayfalar var. Açtığı diğer excelden aldığı verileri ilgili şubenin sayfasına kaydettireceğim.
Lütfen acil yardım.
Sub aktar()
dosyasayisi = [d65536].End(3).Row - 1
For i = 2 To dosyasayisi + 1
yol = Cells(i, 4)
Dosya = Cells(i, 5)
Workbooks.Open Filename:=yol & "\" & Dosya
madet = Worksheets(1).Range("I8")
asube = Worksheets(1).Range("A8")
Windows("taban.xlsm").Activate
?subesorgula = Worksheets("ŞUBELER").Range("A1:A65536").Find(asube).Row
On Error Resume Next
If subesorgula = Empty Then
MsgBox (Dosya & "dosyasında şube bölümü hatalı" _
& Chr(10) & "Lütfen Kontol Edip Tekrar Deneyin. Veya" _
& Chr(10) & "!!!!!!!!!!!!!!!!!"), vbExclamation, "Dikkat !"
Exit Sub
Else
Cells(i, 2) = subesorgula
?sayfaa = Sheets(ŞUBELER).Cells(subesorgula, 2)
Cells(i, 3) = sayfaa
ThisWorkbook.Sheets(sayfaa).Cells(1, 1) = madet
Windows("" & Dosya).Activate
ActiveWindow.Close
End If
Next
End Sub
Sonra bulduğu satır numarasının ikinci sütünunda aynı şubenin adı var. İkinci soru işaretinde o adı sayfaa değişkenine atamak istiyorum. Yani şube kodunu bulduğu satırın ikinci sütünundan şube adını öğrenim "sayfaa" değişkenine atayacak.. Burada kod çalışmıyor. Sayfaa değişkeni boş geliyor.
Son aşamada her şube için mevcut excelde sayfalar var. Açtığı diğer excelden aldığı verileri ilgili şubenin sayfasına kaydettireceğim.
Lütfen acil yardım.
Sub aktar()
dosyasayisi = [d65536].End(3).Row - 1
For i = 2 To dosyasayisi + 1
yol = Cells(i, 4)
Dosya = Cells(i, 5)
Workbooks.Open Filename:=yol & "\" & Dosya
madet = Worksheets(1).Range("I8")
asube = Worksheets(1).Range("A8")
Windows("taban.xlsm").Activate
?subesorgula = Worksheets("ŞUBELER").Range("A1:A65536").Find(asube).Row
On Error Resume Next
If subesorgula = Empty Then
MsgBox (Dosya & "dosyasında şube bölümü hatalı" _
& Chr(10) & "Lütfen Kontol Edip Tekrar Deneyin. Veya" _
& Chr(10) & "!!!!!!!!!!!!!!!!!"), vbExclamation, "Dikkat !"
Exit Sub
Else
Cells(i, 2) = subesorgula
?sayfaa = Sheets(ŞUBELER).Cells(subesorgula, 2)
Cells(i, 3) = sayfaa
ThisWorkbook.Sheets(sayfaa).Cells(1, 1) = madet
Windows("" & Dosya).Activate
ActiveWindow.Close
End If
Next
End Sub