dgdizayn
Altın Üye
- Katılım
- 7 Mart 2011
- Mesajlar
- 138
- Excel Vers. ve Dili
- OFFİCE 2019 EN
- Altın Üyelik Bitiş Tarihi
- 04-05-2028
Merhabalar,
Aşağıdaki kodlarla, kapalı olan bir excel dosyasını açıp istediğim sütunlara veri girişi yapabiliyorum. Hedef dosyayı tüm herkese açık paylaşım yapıp, herkes tarafından girilebilir yaptım. Bu kodlarla ise kapalı excel dosyasını aç, veriyi yaz sonra kaydetip kapat yerine açık olan excel dosyasına veriyi yaz sonra kapatmadan kaydet yap istiyorum. Bu konuda yardımcı olabilir misiniz.
Teşekkürler.
Aşağıdaki kodlarla, kapalı olan bir excel dosyasını açıp istediğim sütunlara veri girişi yapabiliyorum. Hedef dosyayı tüm herkese açık paylaşım yapıp, herkes tarafından girilebilir yaptım. Bu kodlarla ise kapalı excel dosyasını aç, veriyi yaz sonra kaydetip kapat yerine açık olan excel dosyasına veriyi yaz sonra kapatmadan kaydet yap istiyorum. Bu konuda yardımcı olabilir misiniz.
Teşekkürler.
Kod:
Sub BulYaz()
Dim wbA As Workbook ' açık olan dosya
Dim wbB As Workbook ' uzak dosya
Dim wsA As Worksheet ' açık olan dosyadaki sayfa
Dim wsB As Worksheet ' uzak dosyadaki sayfa
Dim kelime As String ' aranacak kelime
Dim sutunNo As Integer ' yazılacak sütun numarası
Dim sonuc As Range ' arama sonucu
Dim satir As Long ' arama sonucu satır numarası
Dim hedefHucresi As Range ' yazılacak hücre
Sheets("EKRAN").Select
Range("E2003").Value = Environ("USERNAME")
Range("F2003").Value = "=NOW()"
' Açık olan dosyanın ataması
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
' Uzak dosyanın ataması
Set wbB = Workbooks.Open("c:/Güncel.XLSX")
Set wsB = wbB.Worksheets("Sheet1")
' Aranacak kelime ve yazılacak sütun numarasının alınması
kelime = wsA.Range("B2003").Value
sutunNo = wsA.Range("A2001").Value
sutunNo1 = wsA.Range("A2002").Value
sutunNo2 = wsA.Range("A2003").Value
sutunNo3 = wsA.Range("A2005").Value
' Arama işlemi
Set sonuc = wsB.Cells.Find(kelime, LookIn:=xlValues, LookAt:=xlWhole)
' Aranan kelime bulunduysa yazılacak hücrenin belirlenmesi
If Not sonuc Is Nothing Then
satir = sonuc.Row
Set hedefHucresi = wsB.Cells(satir, sutunNo)
Set hedefHucresi1 = wsB.Cells(satir, sutunNo1)
Set hedefHucresi2 = wsB.Cells(satir, sutunNo2)
Set hedefHucresi3 = wsB.Cells(satir, sutunNo3)
' Yazma işlemi
hedefHucresi.Value = wsA.Range("D2003").Value
hedefHucresi1.Value = wsA.Range("E2003").Value
hedefHucresi2.Value = wsA.Range("F2003").Value
hedefHucresi3.Value = wsA.Range("H2005").Value
Else
MsgBox "mesaj"
wbB.Save
wbB.Close
wbA.Save
Exit Sub
End If
' Dosyaların kaydedilmesi ve kapatılması
wbB.Save
wbB.Close
wbA.Save