Send data frem og tilbage mellem to excelfiler.

Case vbYes

vbOK 1 OK button pressed
vbCancel 2 Cancel button pressed
vbAbort 3 Abort button pressed
vbRetry 4 Retry button pressed
vbIgnore 5 Ignore button pressed
vbYes 6 Yes button pressed
vbNo 7 No button pressed

rettet og testet, jeg droppede IndsætKunde funktionen og bruger så SøgKunde til begge.

Const kildeSti = "C:\testfil\Kilde.xls"      'tilpasses
Dim kXLS, kildeRækker
Const kundeNrindtastesI = "A3:A3"                  'kan tilpasses

Private Sub worksheet_change(ByVal target As Excel.Range)
    Dim kundeNavn As String
    Dim i As Integer
    Dim Valgt As Variant
    Dim ws As Worksheet

    Set ws = Worksheets("Ark1")

    If Not Intersect(target, ws.Range(kundeNrindtastesI)) Is Nothing Then
        If Len(target) > 0 Then
            kundeNavn = søgKunde(target.Value, 0, False)    ' bruger samme funktion som i gem, Falsk gør at den læser
            If kundeNavn <> "" Then
                ws.Cells(target.Row, target.Column + 1) = kundeNavn
            Else
                MsgBox ("Kundenr. " + CStr(target.Value) + " kunne ikke findes!")
                ws.Cells(target.Row, target.Column + 1) = ""

                i = MsgBox("Skal kunde gemme?" & Chr(13), vbQuestion + vbYesNo)

                Select Case i
                Case vbYes
                    Valgt = InputBox("Indsæt kundenavn")
                    If Valgt = "" Then
                        Valgt = MsgBox("Ingen kunde at oprette", vbExclamation)
                        Exit Sub
                    ElseIf Valgt <> "" Then
                        ws.Cells(target.Row, target.Column + 1) = Valgt
                        søgKunde target.Value, Valgt, True    ' bruger samme funktion som i søg, True, gør at den gemmer
                        Exit Sub
                    End If
                Case vbNo
                    Exit Sub

                End Select

            End If
        Else
            ws.Cells(target.Row, target.Column + 1) = ""
        End If
    End If
End Sub
Private Function søgKunde(knr, Valgt, Gem As Boolean)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open kildeSti

        .ActiveWorkbook.Sheets(1).Activate
        kildeRækker = .ActiveCell.SpecialCells(xlLastCell).Row

        For r = 2 To kildeRækker
            If knr = .Cells(r, 1) Then
                If Gem Then ' der gemmes
                    .Cells(r, 2) = Valgt
                    Exit For
                Else ' der læses
                    søgKunde = .Cells(r, 2)
                    lukObject
                    Exit Function
                End If
            End If

        Next r
    End With
    lukObject
    søgKunde = ""
End Function
Private Sub lukObject()
    With kXLS

        .ActiveWorkbook.Close SaveChanges:=True
        .Application.Quit
    End With
    Set kXLS = Nothing
End Sub

I stedet for at hente og skrive over imod en excel fil kan dette så laves over imod en access database på samme måde?

Det kan det godt, men det er ikke lige min speciale, da jeg aldrig har gjort det, men jeg ved at det kan gøres.

Du må nok få en anden til at svare på det. ;-))

Virkede koden ellers, som den skulle. ??

Hej Kabbak,

undskyld svartiden, men skulle lige have konfronteret løsningen. Hvis jeg gerne vil have flere konstanter på a la kundenr, som adresse, by og land hvordan får jeg disse med over når man indtaster et kundenummer.

De skulle gerne hentes over på samme måde som kundenavn. Alle dataene står på samme streng/række over i Kildefilen. Samme funktion som kundenr skal tilføjes hvis ikke der er indtast nogen data endnu. 

Jeg har forsøgt at opdatere den udgave du sendte men kan det gøres nemmere i stedet for at skulle oprette ny funktioner hele tiden?

Koden fungere ikke som den er pt..

Const kildeSti = "C:\Suzlon\Kilde.xls"      'tilpasses
Dim kXLS, kildeRækker
Const kundeNr_indtastes_I = "A3:A3" 'kan tilpasses

Private Sub worksheet_change(ByVal target As Excel.Range)
    Dim i As Integer
    Dim kundeNavn As String
    Dim adresse As String
    Dim by As String
    Dim land As String
   
    Dim KundeValg As Variant
    Dim adresseValg As Variant
    Dim byValg As Variant
    Dim landValg As Variant
       
    Dim ws As Worksheet

    Set ws = Worksheets("Ark1")

    If Not Intersect(target, ws.Range(kundeNr_indtastes_I)) Is Nothing Then
        If Len(target) > 0 Then
            kundeNavn = søgKunde(target.Value, 0, False)    ' bruger samme funktion som i gem, Falsk gør at den læser
            adresse = søgKunde2(target.Value, 0, False)
            by = søgKunde3(target.Value, 0, False)
            land = søgKunde4(target.Value, 0, False)
           
            If kundeNavn <> "" Then
                ws.Cells(target.Row, target.Column + 1) = kundeNavn
            Else
                MsgBox ("Kundenr. " + CStr(target.Value) + " kunne ikke findes!")
                ws.Cells(target.Row, target.Column + 1) = ""

                i = MsgBox("Skal kunde gemme?" & Chr(13), vbQuestion + vbYesNo) 'Kunde oprettes og gemmes
                Select Case i
                Case vbYes
                    KundeValg = InputBox("Indsæt kundenavn")
                    If KundeValg = "" Then
                        KundeValg = MsgBox("Ingen kunde at oprette", vbExclamation)
                        Exit Sub
                    ElseIf KundeValg <> "" Then
                        ws.Cells(target.Row, target.Column + 1) = KundeValg
                        søgKunde target.Value, KundeValg, True    ' bruger samme funktion som i søg, True, gør at den gemmer
                        Exit Sub
                    End If
                Case vbNo
                    Exit Sub
                End Select
         
             
            If adresse <> "" Then
                ws.Cells(target.Row + 2, target.Column + 3) = adresse
            Else
                MsgBox ("adresse. " + CStr(target.Value) + " kunne ikke findes!")
                ws.Cells(target.Row + 2, target.Column + 3) = ""
               
                i = MsgBox("Skal adresse gemme?" & Chr(13), vbQuestion + vbYesNo) 'adresse oprettes og gemmes
                Select Case i
                Case vbYes
                    adresseValg = InputBox("Indsæt adresse")
                    If adresseValg = "" Then
                        adresseValg = MsgBox("Ingen adresse er oprettet", vbExclamation)
                        Exit Sub
                    ElseIf adresseValg <> "" Then
                        ws.Cells(target.Row + 2, target.Column + 3) = adresseValg
                        søgKunde target.Value, adresseValg, True    ' bruger samme funktion som i søg, True, gør at den gemmer
                        Exit Sub
                    End If
                Case vbNo
                    Exit Sub
                End Select
         
             
            If by <> "" Then
                ws.Cells(target.Row + 7, target.Column + 2) = by
            Else
                MsgBox ("by " + CStr(target.Value) + " kunne ikke findes!")
                ws.Cells(target.Row + 7, target.Column + 2) = ""
               
                i = MsgBox("Skal by gemme?" & Chr(13), vbQuestion + vbYesNo) 'by oprettes og gemmes
                Select Case i
                Case vbYes
                    byValg = InputBox("Indsæt bynavn")
                    If byValg = "" Then
                        byValg = MsgBox("Ingen by at oprette", vbExclamation)
                        Exit Sub
                    ElseIf byValg <> "" Then
                        ws.Cells(target.Row + 7, target.Column + 2) = byValg
                        søgKunde target.Value, byValg, True    ' bruger samme funktion som i søg, True, gør at den gemmer
                        Exit Sub
                    End If
                Case vbNo
                    Exit Sub
                End Select
           
             
            If land <> "" Then
                ws.Cells(target.Row + 8, target.Column + 3) = land
            Else
                MsgBox ("land " + CStr(target.Value) + " kunne ikke findes!")
                ws.Cells(target.Row + 8, target.Column + 3) = ""
               
               
                i = MsgBox("Skal land gemmes?" & Chr(13), vbQuestion + vbYesNo) 'land oprettes og gemmes
                Select Case i
                Case vbYes
                    landValg = InputBox("Indsæt Landenavn")
                    If landValg = "" Then
                        landValg = MsgBox("Ingen lande info", vbExclamation)
                        Exit Sub
                    ElseIf landValg <> "" Then
                        ws.Cells(target.Row + 8, target.Column + 3) = landValg
                        søgKunde target.Value, landValg, True    ' bruger samme funktion som i søg, True, gør at den gemmer
                        Exit Sub
                    End If
                Case vbNo
                    Exit Sub
                End Select
            End If
            End If
            End If
            End If
        Else
            ws.Cells(target.Row, target.Column + 1) = ""
            ws.Cells(target.Row + 2, target.Column + 3) = ""
            ws.Cells(target.Row + 7, target.Column + 2) = ""
            ws.Cells(target.Row + 8, target.Column + 3) = ""
        End If
    End If
End Sub
Private Function søgKunde(knr, KundeValg, Gem As Boolean)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open kildeSti

        .ActiveWorkbook.Sheets(1).Activate
        kildeRækker = .ActiveCell.SpecialCells(xlLastCell).Row

        For r = 2 To kildeRækker
            If knr = .Cells(r, 1) Then
                If Gem Then ' der gemmes
                    .Cells(r, 2) = KundeValg
                    Exit For
                Else ' der læses
                    søgKunde = .Cells(r, 2)
                    lukObject
                    Exit Function
                End If
            End If

        Next r
    End With
    lukObject
End Function
Private Function søgKunde2(knr, adresseValg, Gem As Boolean)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open kildeSti

        .ActiveWorkbook.Sheets(1).Activate
        kildeRækker = .ActiveCell.SpecialCells(xlLastCell).Row

        For r = 2 To kildeRækker
            If knr = .Cells(r, 1) Then
                If Gem Then ' der gemmes
                    .Cells(r, 3) = adresseValg
                    Exit For
                Else ' der læses
                    søgKunde2 = .Cells(r, 3)
                    lukObject
                    Exit Function
                End If
            End If

        Next r
    End With
    lukObject
End Function
Private Function søgKunde3(knr, byValg, Gem As Boolean)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open kildeSti

        .ActiveWorkbook.Sheets(1).Activate
        kildeRækker = .ActiveCell.SpecialCells(xlLastCell).Row

        For r = 2 To kildeRækker
            If knr = .Cells(r, 1) Then
                If Gem Then ' der gemmes
                  .Cells(r, 4) = byValg
                    Exit For
                Else ' der læses
                    søgKunde3 = .Cells(r, 4)
                    lukObject
                    Exit Function
                End If
            End If

        Next r
    End With
    lukObject
End Function
Private Function søgKunde4(knr, landValg, Gem As Boolean)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open kildeSti

        .ActiveWorkbook.Sheets(1).Activate
        kildeRækker = .ActiveCell.SpecialCells(xlLastCell).Row

        For r = 2 To kildeRækker
            If knr = .Cells(r, 1) Then
                If Gem Then ' der gemmes
                    .Cells(r, 5) = landValg
                    Exit For
                Else ' der læses
                    søgKunde4 = .Cells(r, 5)
                    lukObject
                    Exit Function
                End If
            End If

        Next r
    End With
    lukObject
End Function
Private Sub lukObject()
    With kXLS

        .ActiveWorkbook.Close SaveChanges:=True
        .Application.Quit
    End With
    Set kXLS = Nothing
End Sub

Den stopper i If Not Intersect(target, ws.Range(kundeNr_indtastes_I)) Is Nothing Then

Hvorfor?

Hej Kabbak,

vil du have pointene for det første arbejde?

Kan forstå du ikke vil hjælpe mere så jeg må oprette spørgsmålet igen, hvor jeg kan få tilføjet flere kolonner og overføre dataene til andre excel og word ark. Samt skal have muligheden for at skrive tilbage igen på samme måde som i det første eksempel..

Hvor mange point vil du have for at lave koden til det??

Jeg havde ikke set at du havde skrevet mere.'

dit spørgsmål fra 28/03-2008 14:50:41, har jeg ikke lavet, men den virkede her.

Tag bare point selv, jeg har nok.

Ja, men jeg vil heller have en løsning. Please..

Jeg har modificeret dit første forslag til det forslag der ligger d. 26/03-2008 21:32:42 og det er dertil mit svar fra d. 28/03-2008 14:50:41 relatere sig til..

Jeg har en række med informationer i ark1 som jeg skal have over i enkelte celler i ark2. Hvis der ændres i ark2 skal dette returneres til ark1.

Rækken tilhøre et kundenummer i ark1.

Er det ikke muligt at lave en funktion som kan søge og hente til alle celler i ark2 fra en række i ark1.. Ændringer skal bare returneres på samme måde som i det første eksemple du lavede bare for alle celler i samme række.

Er det nemmere hvis jeg lægger filerne op?

Så ville jeg nok gribe det anderledes an.

Jeg ville hente alle data fra "C:\testfil\Kilde.xls"  ind i en variabel og så læse dem derfra, det vil øge hastigheden på søgningen enormt.

Når så du har ændringer, ville jeg gemme dem i variablen og så skrive dem tilbage, inden du lukker excel.

Det tror jeg også vil være en go ide.. Koden vil blive alt for sløv på den anden måde, samt der skal være op til flere bruger, der skal kunne hente og skrive tilbage..

Det skal virke over mod word filer og excel filer.. Er det muligt?

Kan du sende eksempel filer, "Kilde.xls" og brugerens fil/er, så ser jeg på det fra i morgen aften.

kabbak snabela tiscali dot dk

Jeps- skal jeg gøre.. Du får den på mail..


Mvh

Ole

luk