iki kodu birlestirmek

E

Eser Gökay

Katılım
28 Haziran 2007
Mesajlar
246
Excel Vers. ve Dili
Excel 2003 Tr
arkadaslar gunaydınlar...

bir sayfaya eklenmesi gereken iki kodkod var. bunları birleştirmem lazım. ancak bir turlu beceremedim. bir yerini cozuyorum baska bir yerde patlıyor. rica etsem yardımcı olur musunuz.

Sayın COST_CONTROL'den aldığım mukerrer kayıt için aldığım ve Sayın Ripek'den de veritabanından bilgi çeken kodların her ikiside aşağıdadır.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [E4:E65536,G4:G65536,I4:J65536,M4:M65536]) Is Nothing Then Exit Sub
If IsEmpty(Target) Or InStr(1, Target.Address, ":") <> 0 Then Exit Sub
If Cells(Target.Row, "E") <> "" And Cells(Target.Row, "G") <> "" And Cells(Target.Row, "I") <> "" And Cells(Target.Row, "J") <> "" And Cells(Target.Row, "M") <> "" Then
SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
If SAY > 1 Then
Set BUL = Columns(Target.Column).Find(Target)
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
If Cells(Target.Row, "E") = Cells(BUL.Row, "E") And Cells(Target.Row, "G") = Cells(BUL.Row, "G") And Cells(Target.Row, "I") = Cells(BUL.Row, "I") And Cells(Target.Row, "J") = Cells(BUL.Row, "J") And Cells(Target.Row, "M") = Cells(BUL.Row, "M") Then
SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
End If
Set BUL = Columns(Target.Column).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
GoTo UYARI
End If: End If: End If
GoTo SON
UYARI: ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
If ONAY = vbNo Then
Range("E" & Target.Row, "O" & Target.Row) = ""
Target.Select
Exit Sub: End If
Target.Offset(1, 0).Select
SON:
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'On Error Resume Next

If Intersect(Target, [G4:G65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then
Range("E" & Target.Row & ":f" & Target.Row).Select
Selection.ClearContents
Range("H" & Target.Row & ":O" & Target.Row).Select
Selection.ClearContents
Cells(Target.Row, "G").Select
Exit Sub
Else
Baglan:
End If

If Intersect(Target, [G4:G65536]) Is Nothing Then Exit Sub
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak1, Kaynak2, Kaynak3, verginosu As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak1 = "z:\belgelerim\2007 office muhasebe\program_data\veritabani.xls"
Kaynak2 = "d:\belgelerim\2007 office muhasebe\program_data\veritabani.xls"

Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak1) = True Then
Kaynak3 = Kaynak1
ElseIf FSO.FileExists(Kaynak2) = True Then
Kaynak3 = Kaynak2
Else
MsgBox "Veritabani.xls Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If
verginosu = CurrentValue
SQLStr = "SELECT M&#220;KELLEFADISOYADI,VDA&#304;RES&#304;,VERG&#304;NO,ADRES&#304; FROM [data$] WHERE VERG&#304;NO=" & verginosu
Set Baglanti = CreateObject("ADODB.Connection")
With Baglanti
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Properties("Data Source").Value = Kaynak3
.CursorLocation = adUseServer
.Mode = adModeReadWrite
.Open
End With

If Err = 0 Then
Set Kayit1 = CreateObject("ADODB.Recordset")
With Kayit1
.ActiveConnection = Baglanti
.CursorLocation = adUseServer
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = SQLStr
.Open
End With
'***********************************************************************
If Kayit1.RecordCount = 1 Then
Cells(CurrentRow, "e").Value = Kayit1("M&#220;KELLEFADISOYADI")
Cells(CurrentRow, "f").Value = Kayit1("VDA&#304;RES&#304;")
Cells(CurrentRow, "h").Value = Kayit1("ADRES&#304;")
Else
MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
UserForm1.Show
End If
Else
Son:
MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi"
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
Set FSO = Nothing
Target.Offset(1, 0).Select
End Sub
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Sn muhasebeci eser ben sadece vergi nosuna g&#246;re m&#252;kerrer kay&#305;t kontorl&#252;n&#252; sa&#287;lad&#305;m Siz kaynak1 de&#287;i&#351;kenini d&#252;zeltiniz sadece.
Di&#287;er de&#287;i&#351;kenlerin kontorl&#252;n&#252; konuya vak&#305;f olmad&#305;&#287;&#305;m i&#231;in anlamad&#305;m detayl&#305; anlat&#305;rsan&#305;z belki&#351; yard&#305;mc&#305; olabilirim.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'On Error Resume Next

'If Intersect(Target, [G4:G65536]) Is Nothing Then Exit Sub
'If Target.Value = "" Then
'Range("E" & Target.Row & ":f" & Target.Row).Select
'Selection.ClearContents
'Range("H" & Target.Row & ":O" & Target.Row).Select
'Selection.ClearContents
'Cells(Target.Row, "G").Select
'Exit Sub
'Else
'Baglan:
'End If

    If Intersect(Target, [g4:g65536]) Is Nothing Then Exit Sub                      'a4:a65536 aral&#305;&#287;&#305; de&#287;i&#351;memi&#351;se &#231;&#305;k
    If IsEmpty(Target) Then                                                         'de&#287;i&#351;en alan bo&#351;sa
        Range("e" & Target.Row & ":f" & Target.Row).Select: Selection.ClearContents                         'B:AB aral&#305;&#287;&#305;ndaki sat&#305;rlar&#305; se&#231; ve i&#231;eri&#287;ini bo&#351;alt
        Range("H" & Target.Row & ":O" & Target.Row).Select: Selection.ClearContents
        Target.Select                                                               'de&#287;i&#351;en h&#252;creyi se&#231;
    Exit Sub: End If                                                                'prosod&#252;rden &#231;&#305;k
    
    'm&#252;kerrer kay&#305;t kontol&#252;
    If Cells(Target.Row, "g") <> "" Then                                            'g s&#252;tununda de&#287;i&#351;en alan bo&#351; de&#287;ilse
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)                 's&#252;tundaki hedef de&#287;eri ta&#351;&#305;yan verileri say.
    If SAY > 1 Then                                                                 '1 den fazla ise
    Set BUL = Columns(Target.Column).Find(Target)                                   'de&#287;eri ta&#351;yan h&#252;creleri bul
    If Not BUL Is Nothing Then                                                      '?
    ADRES = BUL.Address                                                             '?
    Do                                                                              '?
    If Cells(Target.Row, "g") = Cells(BUL.Row, "g") Then                            '?
        SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))  '?
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)                                  '?
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES                          '?
    GoTo UYARI                                                                      'm&#252;kerrer kay&#305;t uyar&#305; ver alt makrosuna git
    End If: End If: End If
    GoTo Baglan                                                                     'm&#252;kerrer kay&#305;t yoksa ba&#287;lan alt makrosuna git
UYARI:
    ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & _
           Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")   'm&#252;kerrer kay&#305;t devam edecekmisiniz sorusunu sor?
    If ONAY = vbNo Then                                                                         'devam edilmeyecekse
        Range("e" & Target.Row & ":f" & Target.Row).Select: Selection.ClearContents                         'B:AB aral&#305;&#287;&#305;ndaki sat&#305;rlar&#305; se&#231; ve i&#231;eri&#287;ini bo&#351;alt
        Range("H" & Target.Row & ":O" & Target.Row).Select: Selection.ClearContents
        Target.Select:                                              Selection.ClearContents     'de&#287;i&#351;en h&#252;creyi se&#231; ve sil.
        Exit Sub                                                                                'makrodan &#231;&#305;k
    End If                                                                                      'kontrolden &#231;&#305;k
    '*****************************************************************
'Ripek - 26/12/2007
'veri taban&#305;na ba&#287;lan
Baglan:




'If Intersect(Target, [G4:G65536]) Is Nothing Then Exit Sub
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak1, Kaynak2, Kaynak3, verginosu As String
'************************************************* **********************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak1 = "C:\Users\CASPER\Desktop\Ornek\veritabani.xls"
Kaynak2 = "d:\belgelerim\2007 office muhasebe\program_data\veritabani.xls"

Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak1) = True Then
Kaynak3 = Kaynak1
ElseIf FSO.FileExists(Kaynak2) = True Then
Kaynak3 = Kaynak2
Else
MsgBox "Veritabani.xls Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If
verginosu = CurrentValue
SQLStr = "SELECT M&#220;KELLEFADISOYADI,VDA&#304;RES&#304;,VERG&#304;NO,ADRES&#304; FROM [data$] WHERE VERG&#304;NO=" & verginosu
Set Baglanti = CreateObject("ADODB.Connection")
With Baglanti
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Properties("Data Source").Value = Kaynak3
.CursorLocation = adUseServer
.Mode = adModeReadWrite
.Open
End With

If Err = 0 Then
Set Kayit1 = CreateObject("ADODB.Recordset")
With Kayit1
.ActiveConnection = Baglanti
.CursorLocation = adUseServer
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = SQLStr
.Open
End With
'************************************************* **********************
If Kayit1.RecordCount = 1 Then
Cells(CurrentRow, "e").Value = Kayit1("M&#220;KELLEFADISOYADI")
Cells(CurrentRow, "f").Value = Kayit1("VDA&#304;RES&#304;")
Cells(CurrentRow, "h").Value = Kayit1("ADRES&#304;")
Else
MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
UserForm1.Show
End If
Else
Son:
MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi"
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
Set FSO = Nothing
Target.Offset(1, 0).Select
End Sub
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
m&#252;kerrer kay&#305;r i&#231;in Kodlar&#305; denemedim ama k&#305;rm&#305;z&#305; sat&#305;rlar yerine ye&#351;il sat&#305;rlar&#305; kullanarak veritaban&#305; sorgusu i&#231;in birle&#351;tirin. hatano&#305;n sebebi bence vergi noyu girdi&#287;imiz h&#252;crenin di&#287;erleri ile silinmesidir.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [E4:E65536,G4:G65536,I4:J65536,M4:M65536]) Is Nothing Then Exit Sub
If IsEmpty(Target) Or InStr(1, Target.Address, ":") <> 0 Then Exit Sub
If Cells(Target.Row, "E") <> "" And Cells(Target.Row, "G") <> "" And Cells(Target.Row, "I") <> "" And Cells(Target.Row, "J") <> "" And Cells(Target.Row, "M") <> "" Then
SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
If SAY > 1 Then
Set BUL = Columns(Target.Column).Find(Target)
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
If Cells(Target.Row, "E") = Cells(BUL.Row, "E") And Cells(Target.Row, "G") = Cells(BUL.Row, "G") And Cells(Target.Row, "I") = Cells(BUL.Row, "I") And Cells(Target.Row, "J") = Cells(BUL.Row, "J") And Cells(Target.Row, "M") = Cells(BUL.Row, "M") Then
SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
End If
Set BUL = Columns(Target.Column).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
GoTo UYARI
End If: End If: End If
GoTo SON
UYARI: ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
If ONAY = vbNo Then
'[B][color=red]Range("E" & Target.Row, "O" & Target.Row) = ""[/color][/B]
'[B][color=red]Target.Select[/color][/B]
[B][color=green]Range("E" & Target.Row, "F" & Target.Row) = ""[/color][/B]
[B][color=green]Range("H" & Target.Row, "O" & Target.Row) = ""[/color][/B]
[B][color=green]Target.VALUE= ""[/color][/B]

Exit Sub: End If
Target.Offset(1, 0).Select
SON:
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst