VBA na přenos dat Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

junis
nováček
Příspěvky: 39
Registrován: březen 22
Pohlaví: Muž
Stav:
Offline

VBA na přenos dat

Příspěvekod junis » 07 zář 2022 19:10

Ahoj.
Šlo by napsat makro které:
Vyhledá v listu "sestava" ve sloupci Q všechny buňky které mají hodnotu 1, ty nakopíruje, pak mi nabídne v PC vybrat soubor kde je již list "V seznamu ANO" a tam do slouce Q vloží data ? Ostatní buňky zůstanou beze změny.

Reklama
Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: VBA na přenos dat

Příspěvekod elninoslov » 07 zář 2022 22:19

Aké dáta vloží na list "V seznamu ANO" do stĺpca Q ??? Veď žiadne nekopírujete. Na liste "sestava" sú predsa v Q, ako uvádzate, iba 1 a niečo iné. A kopírujete práve tie 1, ako tvrdíte. Tak načo ich kopírovať. Stačí iba zapísať na list "V seznamu ANO" do stĺpca Q zase iba 1. No ale ako vieme kam? Do ktorých riadkov. Dnes som tuším ešte na fórach zmysluplné zadanie nevidel :roll:
Upresnite to prosím, aj s prílohou.

junis
nováček
Příspěvky: 39
Registrován: březen 22
Pohlaví: Muž
Stav:
Offline

Re: VBA na přenos dat

Příspěvekod junis » 10 zář 2022 08:50

Dobrá, asi jsem se dost nepřesně vyjádřil. No nevadí už jsem to nějak vyřešil. Ale mám ještě jinou věc.
Potřeboval bych však upravid kód (pokud je možno) takto:
Při inventuře načítám kódy zboží (čtečkou), kde se mi do tabulky k jedotlivým položkám vypisuje 1 jako nalezeno.
Vše v pořádku funguje pokud načídám všechny čárové kody s klasickým číslem 123500256 a podobně. Problém je v načtení kódů třeba
B 0025456, nebo D 00568025 nebo A 668545.. nebo jiné písmeno na začátku kódu. Vysvětlím. Jde mi o to, že tyto kódy jsou vyexportovány v sestavě k inventuře bez mezery jako B0025456, přitom v čárovém kódu je mezera. Ovšem ne vždy, někdy je čárový kód bez mezery a pak je vše v pořádku. Proto bych potřebovat zdaby šlo nějak ošetřit, aby v případě načtení těchto položek to nějak ignorovalo tu mezeru (aby to zkrátka našlo položku)
kod je :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Cas As Date, Vyplnuji(), CasZmeny(), Pocet As Long, i As Long

Set Zmena = Intersect(Columns("Q").Resize(Rows.Count - 1).Offset(1, 0), Target)
If Not Zmena Is Nothing Then
Cas = Now()

For Each Are In Zmena.Areas
Pocet = Are.Cells.Count

If Pocet = 1 Then
ReDim Vyplnuji(1 To 1, 1 To 1): Vyplnuji(1, 1) = Are.Value
ReDim CasZmeny(1 To 1, 1 To 1): CasZmeny(1, 1) = Are.Offset(0, 1).Value
Else
Vyplnuji = Are.Value
CasZmeny = Are.Offset(0, 1).Value
End If

For i = 1 To Pocet
CasZmeny(i, 1) = IIf(Vyplnuji(i, 1) = 1, Cas, Empty)
Next i

Application.EnableEvents = False
Are.Offset(0, 1).Value = CasZmeny
Application.EnableEvents = True
Next Are
End If
End Sub

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: VBA na přenos dat

Příspěvekod elninoslov » 10 zář 2022 13:11

Človeče nešťastný ... najskôr popis, ktorému sa nedá porozumieť, potom bez prílohy, veď my si máme predsa vždy vytvárať prostredie a dáta a usporiadanie pre otestovanie riešenia sami, a následne ako čerešničku uvediete kód z iného listu. Tento nič predsa nehľadá. Dal som si tú prácu, pozrel Vaše príspevky, našiel vlákno ktorého sa to týka, tam prílohu, a v nej TENTO VYHĽADÁVACÍ KÓD

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
Dim BunkaKod As Range
   
    Set BunkaKod = Intersect(Target, Range("J2"))
   
    If Not BunkaKod Is Nothing Then
        If Not IsEmpty(BunkaKod) Then
            On Error Resume Next
           
            With Worksheets("Sestava").Cells(WorksheetFunction.Match(Replace(BunkaKod, " ", ""), Worksheets("Sestava").Columns(IIf(Worksheets("Inventura").Range("F2").Value = 1, "F", "N")), 0), "Q")
                If Err.Number = 0 Then
                    If .Value = 1 Then
                        MsgBox "Tento kód byl již v inventuře načten! Opakuj načtení"
                    Else
                        .Value = 1
                    End If
                   
                    Application.EnableEvents = False
                    BunkaKod.ClearContents
                    Application.EnableEvents = True
                   
                Else
                    MsgBox "Neznámý kód! Produkt nenalezen. Opakuj načtení"
                End If
            End With 'Worksheets("Sestava").Cells(WorksheetFunction.Match(Replace(BunkaKod, " ", ""), Worksheets("Sestava").Columns(IIf(Worksheets("Inventura").Range("F2").Value = 1, "F", "N")), 0), "Q")
           
            On Error GoTo 0
        End If
    End If
End Sub

Stačilo to

Kód: Vybrat vše

...Match(BunkaKod...

upraviť na

Kód: Vybrat vše

...Match(Replace(BunkaKod, " ", "")...


PS: Ak na fórum vkladáte nejaký kód, ktorý je formátovaný a usporiadaný tabulátormi a apostrofami, tak je tak urobený aby bol prehľadnejší, to sú základné vizuálne konvencie pri programovaní. A na to je vymyslená Tag značka "

Kód: Vybrat vše

[code]...[/code]
". Do nej máte ten kód umiestniť. Aby ostal prehľadný, keď si ten kód niekto skopíruje do Excelu a ide Vám ho upraviť a vyskúšať. Vy keď ho nedáte do značiek/Tag-ov, tak sa to vizuálne formátovanie tabulátormi stratí, kód sa zneprehľadní, a dotyčný si to potom musí znovu sprehľadňovať aby sa mu ľahšie Vám pomáhalo.
Je pravda, že niektoré fóra tabulátory v CODE neberú, ale tu áno, a treba to použiť.

Takže: Je toto, to, čo ste chcel?

junis
nováček
Příspěvky: 39
Registrován: březen 22
Pohlaví: Muž
Stav:
Offline

Re: VBA na přenos dat  Vyřešeno

Příspěvekod junis » 10 zář 2022 13:29

NO super. Je to tak, když se dělá moc věcí najednou.
Děkuju. moc jste mi pomohl. Supr


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Přenos souborů SD - USB flash bez PC
    od Asanoth » 29 črc 2023 17:35 » v Sítě - hardware
    11
    2032
    od Grander Zobrazit poslední příspěvek
    30 črc 2023 15:20
  • Přenos product key na druhé PC Příloha(y)
    od sasshrek » 21 lis 2023 17:11 » v Windows 11, 10, 8...
    8
    1566
    od sasshrek Zobrazit poslední příspěvek
    22 lis 2023 08:45
  • prenos suborov a konverzia formatu
    od Sami » 01 dub 2023 12:14 » v Multimédia (filmy, hudba, CDs/DVDs)
    2
    3041
    od Sami Zobrazit poslední příspěvek
    01 dub 2023 13:49
  • Přenos fotek + videí z iPhone do PC (WIN10)
    od Ghoust23 » 05 dub 2023 09:53 » v Mobily, tablety a jiná přenosná zařízení
    4
    1710
    od Ghoust23 Zobrazit poslední příspěvek
    05 dub 2023 11:45
  • Nový tablet a přenos obrazu do televize
    od Radekkk » 16 zář 2023 22:22 » v Mobily, tablety a jiná přenosná zařízení
    2
    3421
    od Radekkk Zobrazit poslední příspěvek
    18 zář 2023 09:08

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 2 hosti