makro der kan sortere og flytte tal

VBA: Læg alle data i Array,
lad makroen skifte destinations-ark ved dato-skift.

Den forstod jeg ikke. Jeg er ikke så skrap til vba.
Kan du forklare det lidt nøjere?

Kan du evt. nøjes med
Subtotaler ?
Sorter først alt efter kolonne A, så
Data >> Subtotaler
Øverst til venstre står der 1-2-3,
det er detaljeringsgraden.

finb

Det giver ingen mening, det du skriver. Jeg har brug for en makro der kan flytte tal når den ser at en ny dag starter. Den skal være i stand til at se hvornår dagen slutter, og kun tage de tal med.

Åben Excel > Udvikler > Visual Basic.. Højreklik på "VBAProject" og vælg Insert > Module..

Skriv følgende:




Sub MoveData()

Dim i As Integer
Dim j As Integer
Dim k As Integer

j = 1
k = 4

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

For i = 4 To 900
    If Sheets("Sheet1").Range("A" & i) <> Sheets("Sheet1").Range("A" & i - 1) Then
        j = j + 1
        Sheets.Add.Name = "Sheet" & j
        k = 4
        Sheets("Sheet1").Range("A1:G3").Copy Destination:=Sheets("Sheet" & j).Range("A1:G3")
    End If
   
    Sheets("Sheet1").Range("A" & i & " : G" & i).Copy Destination:=Sheets("Sheet" & j).Range("A" & k & " : G" & k)
    k = k + 1
Next

End Sub




Gem som "Excel-projektmappe med aktive makroer (*.xlsm)

BEMÆRK: Dit ark med rådata SKAL kaldes "Sheet1". Ellers virker det ikke. Makroen starter med at slette alle andre ark end Sheet1. Hvis du ikke ønsker dette, kan du slette øverste For-løkke. I så fald må du dog ikke have ark i forvejen, der hedder "Sheet2", "Sheet3" osv.. Så går det galt :-)


Demo:
https://gyazo.com/42cab0c95eecd807cbec2912c7a893be

HOV! For-løkken skal selvfølgelig ikke gå fra 4 til 900, men fra 4 til 5471..

Hej zer0c00l

Det virker fantastisk.

Jeg har dog et problem omkring netop navngivning af arkene. Jeg har ikke kun data for Apple, men for mange andre. Ideelt set ville jeg helst åbne en mappe for en given aktie og køre den makro du har givet mig fra en ekstern mappe, istedet for at skulle kopiere den over hver gang. Men så støder jeg ind i run-time error hvor den netop ikke kan lide navne forvirringen. Jeg har prøvet at give "makro mappen" Sheet 1, et helt andet navn, men det kan den ikke lide.

Er der en måde at komme udover den problemstilling?

Hilsen tufexcel

Det er iøvrigt ikke et must at data'en skal have deres eget ark. det er ligeså godt hvis data'ene fra første dag går fra Kolonne A-G, den næste dag fra I-O og så fremdeles. Det er formentlig blot en mindre omskrivning af koden der skal til.

Hej TUF,

De to ting tror jeg sagtens, vi kan fikse.

Jeg får desværre dog nok ikke tid til at kigge mere på det før i morgen, selvom det kribler i fingrene ;-) Håber, det er tids nok.

Jo tak, ingen problemer. Hvornår det passer dig.

Hilsen TUF

Heg TUF,

Jeg har nu induceret en klassisk situation, hvor ingeniøren tror, han ved bedre end arbejdsgiveren, hvad arbejdsgiveren i virkeligheden ønsker :-D

Jeg synes umiddelbart, den mest elegange fremgagsmåde er at åbne arket med rådata, og køre makroen derfra. Udtrækket skal så gemmes i et nyt ark. Således bliver der ikke pillet ved rådata, og historikken er intakt.

For at få adgang til makroen fra alle Excel-ark skal du oprette en ny Excel-fil og kaldet "personal.xlsm" og lægge den i:

C:\Program Files (x86)\Microsoft Office\Office14\XLSTART
(eller den tilsvarende mappe på din computer)

Filen med sorteret data kommer til at ligge i mappen "Dokumenter" som Allstocks.xlsx. For mig er det:

C:\Users\zerocool\Documents\Allstocks.xlsx

Til tilrettede makro hedder:




Sub MoveData()

Dim i As Integer
Dim j As Integer
Dim k As Integer

j = 0
k = 4

Dim ws As Worksheet

Dim wbTarget As Workbook    'workbook where the data is to be pasted
Dim wbThis As Workbook      'workbook from where the data is to copied
Dim strName As String      'name of the source sheet/ target workbook

'set to the current active workbook (the source book)
Set wbThis = ActiveWorkbook
 
'create a new workbook
Set NewBook = Workbooks.Add
With NewBook
    .Title = "All Stocks"
    .Subject = "Stocks"
    .SaveAs Filename:="Allstocks"
End With
   
'open the newly created workbook
Set wbTarget = Workbooks.Open("Allstocks.xlsx")

'activate the target book
wbTarget.Activate

'add Sheet1 and delete all other sheets
Sheets.Add.Name = "temp"

For Each ws In wbTarget.Worksheets
    If ws.Name <> "temp" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

'activate the source book
wbThis.Activate

'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False

'copy data
For i = 4 To 900
    If wbThis.Sheets("Sheet1").Range("A" & i) <> wbThis.Sheets("Sheet1").Range("A" & i - 1) Then
        j = j + 1
        wbTarget.Sheets.Add.Name = "Sheet" & j
        k = 4
        wbThis.Sheets("Sheet1").Range("A1:G3").Copy Destination:=wbTarget.Sheets("Sheet" & j).Range("A1:G3")
    End If
   
    wbThis.Sheets("Sheet1").Range("A" & i & " : G" & i).Copy Destination:=wbTarget.Sheets("Sheet" & j).Range("A" & k & " : G" & k)
    k = k + 1
Next

'delete temp sheet
For Each ws In wbTarget.Worksheets
    If ws.Name = "temp" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

'save the target book
wbTarget.Save
   
'close the workbook
wbTarget.Close

'activate the source book again
wbThis.Activate
   
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing

End Sub

Hej igen,

Der er en smartere måde at gøre makroer globale på, end ved manuelt at oprette "personal.xlsm".

Åben et nyt Excel-dokument.

Klik på Vis > Makroer > Indspil makro...

Giv makroen et navn og vælg "Gem makro i: Personlig makroprojektmappe"

Skriv "Hej" i A1.

Tryk på stop-knappen i nederste venstre hjørne.

Åben VBA ved Alt+F11.

Åben "VBAProject (PERSONAL.XLSB)" > Modules > Module1

Her ligger den makro, du lige har optaget. Ctrl+A > Delete.

Indsæt din aktie-makro. Gem alt > luk.

Nu kan du fange makroen fra alle eksisterende og nyoprettede ark.

---------------------------------------------------------------

Makroen skal som nævnt køres fra dine Excel-dokumenter med rådata (f.eks. Apple.xlsm), og den opretter således de sorterede data i et nyt dokument.

Lige nu virker makroen kun, hvis arket med rådata hedder "Sheet1". Hvis dette ikke altid er navnet, kan vi godt ændre det til, at der i stedet tages rådata fra det ark, der er aktivt. I så fald må du bare ikke stå på Sheet2, når makroen køres. - Ja, det kan virke som et irriterende valg, men makroen er desværre nødt til at vide, hvor den skal hente data fra ;-)

Undskyld spam!

Jeg kan godt forstå, hvis det lykkedes mig at forvirre dig :-) Brug fremgangsmåden fra #12 men med denne kode, hvor der er tilføjet error handling, hvis "Sheet1" ikke findes, samt hvis filen Allstocks.xlsx allerede er åben.

Jeg lover, der ikke kommer flere ændringer, før du har meldt tilbage :-)


Sub MoveData()

Dim i As Integer
Dim j As Integer
Dim k As Integer

j = 0
k = 4

Dim ws As Worksheet

'does Sheet1 exist? if yes carry on
On Error Resume Next
Set ws = Sheets("Sheet1")
On Error GoTo 0
If Not ws Is Nothing Then

Dim wbTarget As Workbook    'workbook where the data is to be pasted
Dim wbThis As Workbook      'workbook from where the data is to copied
Dim strName As String      'name of the source sheet/ target workbook

'set to the current active workbook (the source book)
Set wbThis = ActiveWorkbook

'is Allstocks.xlsx already open?
If IsWorkBookOpen("Allstocks.xlsx") = True Then
    'all good
Else
    'create a new workbook
    Set NewBook = Workbooks.Add
    With NewBook
        .Title = "All Stocks"
        .Subject = "Stocks"
        .SaveAs FileName:="Allstocks"
    End With
End If

'open the newly created workbook
Set wbTarget = Workbooks.Open("Allstocks.xlsx")

'activate the target book
wbTarget.Activate

'add Sheet1 and delete all other sheets
Sheets.Add.Name = "temp"

For Each ws In wbTarget.Worksheets
    If ws.Name <> "temp" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

'activate the source book
wbThis.Activate

'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False

'copy data
For i = 4 To 900
    If wbThis.Sheets("Sheet1").Range("A" & i) <> wbThis.Sheets("Sheet1").Range("A" & i - 1) Then
        j = j + 1
        wbTarget.Sheets.Add.Name = "Sheet" & j
        k = 4
        wbThis.Sheets("Sheet1").Range("A1:G3").Copy Destination:=wbTarget.Sheets("Sheet" & j).Range("A1:G3")
    End If
   
    wbThis.Sheets("Sheet1").Range("A" & i & " : G" & i).Copy Destination:=wbTarget.Sheets("Sheet" & j).Range("A" & k & " : G" & k)
    k = k + 1
Next

'delete temp sheet
For Each ws In wbTarget.Worksheets
    If ws.Name = "temp" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

'save the target book
wbTarget.Save
   
'close the workbook
wbTarget.Close

'activate the source book again
wbThis.Activate
   
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing

'if Sheet1 did not exist
Else
    MsgBox "Sheet1 does not exist"
End If

End Sub

'function for is-open check
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:  IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Hej zer0c00l

Jeg har fulgt din fremgangsmåde, og ja du har ret det er en glimrende måde at gøre det på. Jeg havde ikke selv tænkt at man kunne gøre sådan.

Tak for fraragende og-må det vist være- tidskrævende arbejde. Jeg vil være lost hvis det ikke for folk som dig. Jeg har købt en glimrende bog :"Vba for dummies" af John Walkenbach. Selvom han skriver underholdende er det en større historie selv at kunne banke sådan en kode sammen.

Sender du et svar

Fortsat go' dag

fra Tufexcel

Hej Tufexcel,

Jeg er glad for, det kunne bruges.

Jeg er selv ret ny i VBA. Jeg har fundet ud af, at jeg personligt lærer et sprog bedst ved at have nogle helt konkrete problemstillinger at arbejde ud fra. På den måde er eksperten.dk et glimrende sted :-)

Rigtig god weekend!