VBA - Makroindspilning

Mon ikke du kan undgå at lave en macro ved blot at lave nogle LOPSLAG-formler?

Kunne du evt. uploade et eksempel?
Det kunne evt. være nødvendigt at programmere direkte i VBA og ikke via indspilning.

@andyness - den oprindelige fil er meget stor og løsningen med LOPSLAG bliver for "tung" at arbejde med.

@supertekst - jeg kan ikke se, hvor jeg kan uploade en fil?

Ok, ja, så er en macro med en event nok løsningen. Hvis filen ligger i en dropbox-mappe, kan du evt. dele filen med et link her.

Link til fil:

https://drive.google.com/file/d/0BzJ9cIt1onS0SHlOOC05TC1fZ3M/view?usp=sharing

nogen god grund til du vil bruge en knap til konvertering?

Jan

Ikke nødvendigvis......

prøv om du kan bruge denne løsning

den henter i via vba hver gang du forlader en celle i kolonne A

https://www.dropbox.com/s/goke8xmsw2voet1/Konvertering%20-%20test%20%281%29.xlsm?dl=0

Umiddelbart virker det - men kun hvis jeg indsætter ind nummer ad gangen. Jeg har brug for at kunne copy/paste en række numre på én gang.

Kan det lade sig gøre, at værdien, der bliver returneret tager udgangspunkt i både kolonne A (Konk varenr) og Kolonne B (Varenumre u/mellemrum) fra arket "Komplet konvertering"

I kolonne A står varenummeret helt originalt. I kolonne B vil mellemrum mm være fjernet. Det kan ikke ses i filen, jeg uploadede da varenumrene er ens i de to kolonner, men et ex. kan være:

Kolonne A 03425  005 50
Kolonne B 3425

Således at det ikke gør nogen forskel, om jeg taster 03425  005 50 eller 3425 i kolonne A på arket "konvertering".

1. Ja  så bliver den måske lidt langsomre
2. Ja
Skal jeg prøve at lave en løsning?

Jan

Kode til konverterings-arkets modul



Kode til modul (Makro)



Jan

du kan også finden den i linket #8

Tusind tak. Det vil jeg forsøge i morgen.

Det ser ud til at virke - fantastisk.....Tusind tak for hjælpen, Jan.

En sidste lille bøn - kan du også hjælpe med at få det til at virke med de ekstra kolonner, jeg har tilføjet i arket "Konvertering"

Kolonne F: Konk. varetekst
Kolonne M: LM varenummer (Billigste alternativ)
Kolonne N: LM varetekst (Billigste alternativ)

Derudover er kolonnen med kundevarenummer slettet

https://drive.google.com/open?id=0BzJ9cIt1onS0ZXFEQmFMZkxqMWM

@Jan - Mit originale ark indeholder ca. 220.000 linjer. Umiddelbart meldes der fejl, hvis jeg forsøger at lave en konvertering, hvor alle linjer tages i brug. Er det for mange linjer?

Et bud:

If Not Intersect(Target, Range("A:A")) Is Nothing Then
        For Each Rcell In wsArea
            Dim iRow As Integer <<<<< kunne lyde som om Integer skal rettes til: Long

Prøv :
https://www.dropbox.com/s/1j0dxmscqpa9z4t/kopi%20af%20konvertering%20-%20test%20.xlsm?dl=0



Jan

Det virker, Jan - du er sør'me skrap til det her.

Jeg går ikke udfra at, jeg kan gøre noget for at det går hurtigere - udover at reducere antallet af linjer i den komplette konvertering?

Mange tak for hjælpen

er det mange linier du copy/paste ?

Jan

Det tager umiddelbart lige lang tid pr linje, uanset om jeg indsætter få eller mange varenumre.

Jeg har fjernet en del leverandører, således at listen er reduceret fra ca. 220.000 linjer til  55.000. Det har ikke ændret på hastigheden. Har lige lavet en lille test

Hvis jeg indsætter 20 varenumre, tager det 2 min.40 sek at køre disse igennem

prøv denne (max 100 copy/paste)

https://www.dropbox.com/s/3bsexcscmgngjy1/kopi%20af%20konvertering%20-%20test%202.xlsm?dl=0


Jan

Er 100 det maksimale?

ja sådan jeg har lavet det, er det ikke nok så øg NewArray, kan måske sænke hastigheden ved en stor øgning!

Jan

Dim MyArray(), wsArray(), lCount As Long, NewArray(1 To 100, 1 To 10), lRow As Long

.......NewArray(1 To 100.........

Jeg har øget til 2000 og det fungerer med acceptabel hastighed.

Jeg oplever dog, at ikke alle værdier returneres. Værdierne i kolonne G, H, I og J (Komplet konvertering) returneres ikke:

https://drive.google.com/open?id=0BzJ9cIt1onS0R0QtLUxsYVVXOEE

ret 5 sidste linie til       
Set newArea = ws.Range("E3", ws.Cells(UBound(NewArray, 1), 14))
så de sidste linier ser således ud

        Set newArea = ws.Range("E3", ws.Cells(UBound(NewArray, 1), 14))
        newArea = NewArray
    End If
    Application.ScreenUpdating = True
End Sub

forresten der skal min sættes 2 ind

Det hele virker perfekt. Tusind, tusind tak for hjælpen:-)

Efter at min konverteringsfil har virket fint, melder den nu fejl, når jeg indsætter en stak varenumre: Run-time error '1004'

newArea = NewArray er markeret med gul når jeg går ind i VBA:

      Next
        Dim newArea As Range
        Set newArea = ws.Range("E3", ws.Cells(UBound(NewArray, 1), 14))
        newArea = NewArray
    End If
    Application.ScreenUpdating = True
End Sub

Dim MyArray(), wsArray(), lCount As Long, NewArray(1 To 2000, 1 To 10), lRow As Long

tror det er fordi NewArray(1 to 2000,1 to 10) skal være NewArray(1 to 2000,1 to 14)

Jan

Det er korrekt at 10 skulle rettes til 14, men fejlen kommer stadig. Kan dette være problemet:

  NewArray(lCount, 10) = MyArray(iRow, 10)


Option Explicit
Dim ws As Worksheet, wsData As Worksheet
Dim Area As Range, wsArea As Range, Rcell As Range


Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim MyArray(), wsArray(), lCount As Long, NewArray(1 To 2000, 1 To 14), lRow As Long
    Set ws = ActiveSheet
    Set wsArea = ws.Range("A3")
    If Not wsArea.Offset(1, 0).Value = "" Then Set wsArea = Range(wsArea, wsArea.End(xlDown))
    Set wsData = Sheets("Komplet konvertering")
    Set Area = wsData.UsedRange
    Set Area = Area.Offset(2, 0)
    MyArray = Area
    If ws.Range("A3") = "" Then Exit Sub
    wsArray = wsArea
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        For lCount = 1 To UBound(wsArray, 1)
            Dim iRow As Long
            For iRow = 1 To UBound(MyArray, 1)
                If MyArray(iRow, 2) = wsArray(lCount, 1) Or MyArray(iRow, 1) = wsArray(lCount, 1) Then
                    NewArray(lCount, 1) = MyArray(iRow, 2)
                    NewArray(lCount, 2) = MyArray(iRow, 3)
                    NewArray(lCount, 3) = MyArray(iRow, 4)
                    NewArray(lCount, 4) = MyArray(iRow, 11)
                    NewArray(lCount, 5) = MyArray(iRow, 5)
                    NewArray(lCount, 6) = MyArray(iRow, 6)
                    NewArray(lCount, 7) = MyArray(iRow, 7)
                    NewArray(lCount, 8) = MyArray(iRow, 8)
                    NewArray(lCount, 9) = MyArray(iRow, 9)
                    NewArray(lCount, 10) = MyArray(iRow, 10)
                    lRow = lCount + 1
                End If
            Next
        Next
        Dim newArea As Range
        Set newArea = ws.Range("E3", ws.Cells(UBound(NewArray, 1), 14))
        newArea = NewArray
    End If
    Application.ScreenUpdating = True
End Sub