Avatar billede TUFexcel Juniormester
30. november 2015 - 11:22 Der er 14 kommentarer og
1 løsning

makro der kan sortere og flytte tal

Hej folkens

Jeg har en masse aktiekurser som jeg ønsker at kunne sortere i. Se upload:

http://web.gratisupload.dk/f/8umq3ciju0/

Jeg ønsker en makro der kan kopiere alle tal i kolonne A til G, flytte dem hen i næste ark og indsætte i celle A4. Hver ark skal kun indeholde den pågældende dag. Den skal altså kigge på datoen i kolonne A, og tage alle tallene for dagen. Det første sæt data er altså A4:G394. Når makroen så har kopieret tallene hen i næste ark, går den så tilbage og starter i række 395. Således fortsætter den indtil alle tal er kopieret hen i andre ark. Her fortsætter den altså ned til række 5471.

Er det noget der er indenfor rammerne af det mulige?

På forhånd tak

Tufexcel
Avatar billede finb Ekspert
30. november 2015 - 12:15 #1
VBA: Læg alle data i Array,
lad makroen skifte destinations-ark ved dato-skift.
Avatar billede TUFexcel Juniormester
30. november 2015 - 13:08 #2
Den forstod jeg ikke. Jeg er ikke så skrap til vba.
Kan du forklare det lidt nøjere?
Avatar billede finb Ekspert
01. december 2015 - 13:00 #3
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.
Avatar billede TUFexcel Juniormester
01. december 2015 - 21:30 #4
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.
Avatar billede zer0c00l Juniormester
02. december 2015 - 11:19 #5
Å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
Avatar billede zer0c00l Juniormester
02. december 2015 - 11:31 #6
HOV! For-løkken skal selvfølgelig ikke gå fra 4 til 900, men fra 4 til 5471..
Avatar billede TUFexcel Juniormester
02. december 2015 - 15:04 #7
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
Avatar billede TUFexcel Juniormester
02. december 2015 - 15:27 #8
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.
Avatar billede zer0c00l Juniormester
02. december 2015 - 16:12 #9
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.
Avatar billede TUFexcel Juniormester
02. december 2015 - 19:05 #10
Jo tak, ingen problemer. Hvornår det passer dig.

Hilsen TUF
Avatar billede zer0c00l Juniormester
03. december 2015 - 09:13 #11
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
Avatar billede zer0c00l Juniormester
03. december 2015 - 11:07 #12
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 ;-)
Avatar billede zer0c00l Juniormester
03. december 2015 - 12:46 #13
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
Avatar billede TUFexcel Juniormester
03. december 2015 - 19:45 #14
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
Avatar billede zer0c00l Juniormester
04. december 2015 - 07:37 #15
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!
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester