Data fra userform placeres på forskellige faneblade - VBA

Hvordan identificeres det rigtige faneblad? Er der en systematik mellem produkter og faneblade.

Evt. send en kopi til pb@supertekst-it.dk

Fanebladene bliver der ændret på!

Alle produkter skal have tastet en oplysning på hvert faneblad... Så når jeg taster i felt1 i min formular, så skal den altid over i fane 1

undskyld - fanebladene bliver der IKKE ændret på

Er det slik:
1) Hvert produkt ligger på samme rad i alle ark
2) Hvert årstall har samme kolonne i alle ark
3) Du taster mange opplysninger om 1 produkt som skal inn i samme celle i alle ark?

Da kan du gjøre slik:
Opprett et eget ark for intasting av data.
fx i området (A2:A22) lager du beskrivelse av egenskaper
  i området (B2:B22) skrives data inn
Da kan du raskt skrive inn alle opplysninger om et produt for et år i (B2:B22)

Etterpå er det lett å lage en kode som legger disse opplysninger i riktig ark.

oyejo du har forstået problemstillingen korrekt.

Men så let er det vel alligevel ikke at lave noget kode der kopierer data over?

Hvis jeg har tastet data ind for ét produkt, skal jeg kører koden og taste for næste produkt... for jeg kan ikke have et ark for hvert produkt

Det finnes folk her som kan gjøre dette mye bedre enn meg, men vi kan prøve!
Hvis andre har en bedre løsning, kan vi trods alt lære noe :-)


Er 2006 i kolonne C, 2005 i kolonne D ... ovs?
og, hva heter dine ark?
Kan du liste opp alle her?

for alle ark gælder:

produkt1 -> B2
produkt2 -> B3...osv

2000 -> C1
2001 -> D1...osv

arkene hedder blot ark1, ark2... osv

Vi får prøve oss fram!
Kan du opprette et ark som heter Inntasting"
i Celle B8 kan du skrive fx 2006
I Celle B9 skriver du så inn de opplysniger som skal i ark1, ark2..ovs vi kan prøve med 20 til å begynne med.

var litt uklar B9 = egenskap til ark1, B10 egenskap til ark 2 .. ovs

prøv så denne kode:
til å begynne med antar vi at det er data for produkt på rad 9 som skal legges inn.
vProduct = 9  .. dette endrer vi senere.



Sub FordeleDataTilArk()
    Dim n As Long
    Dim vdB As Variant
    Dim vFaneNavn As Variant
    Dim lYear As Long
    Dim vProduct As Variant
   
    vFaneNavn = Array("Ark1", "Ark2", "Ark3", "Ark4", "Ark5", _
                      "Ark6", "Ark7", "Ark8", "Ark9", "Ark10", "Ark11", "Ark12", _
                      "Ark13", "Ark14", "Ark15", "Ark16", "Ark17", "Ark18", "Ark19", "Ark20")
   
   
    vProduct = 9
    lYear = Sheets("Inntasting").Range("B8")
   
   
    vdB = Sheets("Inntasting").Range("B9:B28")
    Sheets("Inntasting").Range("B9:B28").ClearContents
    For n = 1 To UBound(vFaneNavn, 1)
    Sheets(vFaneNavn(n)).Cells(vProduct, lYear - 1997) = vdB(n, 1)
    Next
    ThisWorkbook.Sheets("Inntasting").Select
   
End Sub

Skriv disse liner øverst i modulen :

Option Explicit
Option Base 1

Alternativ:


Koden er i Userformen - hvor der er følgende: 3 listbox's og et tekstfelt + knap
Userformen aktiveres fra ThisWorkbook

Dim ræk, antalRækker, kol, antalKol
Dim Ark, produkt, år, tekst
Private Sub f_arkliste_Click()                      'ark er valgt
    Ark = f_arkliste
    visProdukt
End Sub
Private Sub f_ok_Click()
    opdater
    f_ok.Enabled = False
End Sub
Private Sub opdater()
Dim aktP, aktÅ
    ActiveWorkbook.Sheets(Ark).Activate
Rem find produkt
    aktP = findAktuelleProdukt(produkt)
    If aktP > 0 Then
        aktÅ = findAktuelleÅr(år)
        If aktÅ > 0 Then
            Cells(aktP, aktÅ) = f_tekst
        End If
    End If
End Sub
Private Function findAktuelleProdukt(prod)
    For ræk = 3 To antalRækker
        If Cells(ræk, 2) = Val(prod) Then
            findAktuelleProdukt = ræk
            Exit Function
        End If
    Next ræk
    findAktuelleProdukt = 0
End Function
Private Function findAktuelleÅr(år)
    For kol = 3 To antalKol
        If Cells(2, kol) = Val(år) Then
            findAktuelleÅr = kol
            Exit Function
        End If
    Next kol
    findAktuelleÅr = 0
End Function
Private Sub f_produktliste_Click()                  'produkt er valgt
    produkt = f_produktliste
    visÅr
End Sub
Private Sub f_tekst_Change()
    If Len(f_tekst) > 0 Then
        f_ok.Enabled = True
    Else
        f_ok.Enabled = False
    End If
End Sub
Private Sub f_årliste_Click()
    år = f_årliste
    f_tekst.SetFocus
End Sub
Private Sub UserForm_activate()
    f_ok.Enabled = False
    visArk
End Sub
Private Sub visArk()
    f_arkliste.Clear
   
    For Each Ark In ActiveWorkbook.Sheets
        f_arkliste.AddItem Ark.Name
    Next
End Sub
Private Sub visProdukt()
    f_produktliste.Clear
   
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    For ræk = 3 To antalRækker
        f_produktliste.AddItem Cells(ræk, 2)
    Next
End Sub
Private Sub visÅr()
    f_årliste.Clear
   
    antalKol = ActiveCell.SpecialCells(xlLastCell).Column
    For kol = 3 To antalKol
        f_årliste.AddItem Cells(2, kol)
    Next
End Sub


Til inspiration - i givet fald kan du få tilsendt hele test-mappen - mail er tidl. oplyst

hei supertekst
kan du ikke sende den til meg også?
oyejoh@hotmail.com

supert supertekst :-) flott excelbok!
Hvis jeg har forstått stewen riktig,
skal han velge produkt og år,
så skal har skrive opplysninger til alle ark for dette produkt og år.

Er det mulig å gjøre slik at han velger kun produkt og år en gang,
for så å skrive inn alle egenskapene på en gang?
fx. kan han skille de forskjellige egenskaper kun ved å taste enter.

supertekst, det er rigtig godt det du har lavet - din opbygning af ark1-3 er korrekte... dog ikke helt det jeg søgte - men oyejo er inde på noget at det rigtige


For hvert år skal jeg indtaste:
Produkt1: egenskab1, egenskab2, egenskab3
produkt2: egenskab1, egenskab2, egenskab3 ... osv

For 2005 modtager jeg så løbende papirerne på hvert enkelt produkt. Når jeg så modtager papirerne for produkt 1, vil jeg gerne kunne starte userformen, vælge produkt1 og år 2005, hvorefter jeg taster egenskab1, egenskab2, egenskab3 - trykker ok, hvorefter de data jeg tastede for egenskab1..3 bliver indsat på hhv ark1 (egenskab1), ark2 (egenskab2) og ark3 (egenskab3)

Vil det sige, at der en tekstboks pr. faneblad. Disse tekster skal så overføres til hvert faneblad, der således modtager sin individuelle tekst til det valgte produkt - det valgte år?

ja

stewen: Ta en kopi av din xls.bok
Still deg i ark1, (lengst til venstre)
Kjør makro som heter kun en gang førts
Kjør så den andre makro, tror det er en effektiv måte å fordele data på

Sub KunEnGang()
    Sheets.Add.Name = "Inntasting"
    Columns("A:A").ColumnWidth = 18
    Columns("B:B").ColumnWidth = 18
    Columns("D:D").ColumnWidth = 18
   
    Range("A1").Value = "År"
    Range("A2").FormulaR1C1 = "Egenskap 1"
   
    Range("A2").AutoFill Destination:=Range("A2:A21"), Type:=xlFillDefault
   
    Range("B1").Value = "2005"
    Range("B2").FormulaR1C1 = "Verdi 1"
    Range("B2").AutoFill Destination:=Range("B2:B21"), Type:=xlFillDefault
 
    Range("D1").Value = "Produktliste"
    Range("D2").FormulaR1C1 = "produkt 1"
    Range("D2").AutoFill Destination:=Range("D2:D35"), Type:=xlFillDefault
   
    With Range("D2:D35")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
       
    With Range("B1:B21").Interior
        .ColorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    Cells.HorizontalAlignment = xlCenter
End Sub


Sub DataTilArk()
    vFaneNavn = Array("Ark1", "Ark2", "Ark3", "Ark4", "Ark5", "Ark6", _
              "Ark7", "Ark8", "Ark9", "Ark10", "Ark11", "Ark12", "Ark13", _
              "Ark14", "Ark15", "Ark16", "Ark17", "Ark18", "Ark19", "Ark20")
    If IsEmpty(Sheets("Inntasting").Range("B1")) Then
      MsgBox "Skriv inn årstall i Celle B1"
      Exit Sub
    End If
    lYear = Sheets("Inntasting").Range("B1")
    vdB = Sheets("Inntasting").Range("B2:B21")
    rad = Application.InputBox("Velg Produkt i Kolonne D", Type:=8).Row
    Sheets("Inntasting").Range("B2:B21").ClearContents
   
    For n = 0 To UBound(vFaneNavn, 1)
        Sheets(vFaneNavn(n)).Cells(rad, lYear - 1997) = vdB(n + 1, 1)
    Next
    ThisWorkbook.Sheets("Inntasting").Range("B1:B21").Select
End Sub

Korrigeret version - hele filen tilsendes:

Const max = 20
Const ArkNavn = "Ark"                              'modificeres

Dim ræk, antalRækker, kol, antalKol
Dim produkt, år, tekst, produktRæk, årKol
Dim ccT As Control
Private Sub f_ok_Click()
    If checkTekster = True Then
        opdater
    Else
        MsgBox ("Alle tekster er ikke udfyldt")
    End If
End Sub
Private Function checkTekster()
Dim okAntal
    okAntal = 0
   
    For Each ccT In Me.Controls
        If LCase(Left(ccT.Name, 2)) = "tx" Then
            If ccT.Text <> "" Then
                okAntal = okAntal + 1
            End If
        End If
    Next
   
    If okAntal = max Then
        checkTekster = True
    Else
        checkTekster = False
    End If
End Function
Private Sub opdater()
Dim aktP, aktÅ, ark, tNr
    For Each ccT In Me.Controls
        If LCase(Left(ccT.Name, 2)) = "tx" Then
            tNr = Mid(ccT.Name, 3)
            ark = ArkNavn + tNr
           
            ActiveWorkbook.Sheets(ark).Activate
            Cells(produktRæk, årKol) = ccT.Value
        End If
    Next
End Sub
Private Sub f_produktliste_Click()                  'produkt er valgt
    produkt = f_produktliste
    produktRæk = f_produktliste.ListIndex + 3
    visÅr
End Sub
Private Sub f_tekst_Change()
    If Len(f_tekst) > 0 Then
        f_ok.Enabled = True
    Else
        f_ok.Enabled = False
    End If
End Sub
Private Sub f_årliste_Click()
    år = f_årliste
    årKol = f_årliste.ListIndex + 3
    tx1.SetFocus
End Sub
Private Sub UserForm_activate()
    ActiveWorkbook.Sheets(ArkNavn + "1").Activate
    visProdukt
End Sub
Private Sub visProdukt()
    f_produktliste.Clear
   
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    For ræk = 3 To antalRækker
        f_produktliste.AddItem Cells(ræk, 2)
    Next
End Sub
Private Sub visÅr()
    f_årliste.Clear
   
    antalKol = ActiveCell.SpecialCells(xlLastCell).Column
    For kol = 3 To antalKol
        f_årliste.AddItem Cells(2, kol)
    Next
End Sub

Supertekst -> Super godt! Det er et rigtig lækkert stykke arbejde.... Det virker som ønsket - de småting der måtte være skal jeg nok selv få rettet til!

Oyejo -> Jeg har rent faktisk ikke testet dit forslag, selvom det ser fornuftigt ud - supertekst ramte plet, så han får pointene. Tak for forslaget!

Tak for hjælpen begge to

Selv tak - skulle det være en anden gang!

Flott løsning supertekst
likte denne godt:
ActiveCell.SpecialCells(xlLastCell).Column
Vil den også finne siste celle hvis det en tom celle før den siste?