Avatar billede rashid Praktikant
02. februar 2012 - 10:04 Der er 1 kommentar og
1 løsning

Samle data fra 3 ark i et nyt

Hej derude

Jeg ønsker lidt hjælp til noget vba kode, der kan gøre følgende:

jeg har 3 ark, hvor der er resultater for 3 forskellige test.
Disse resultater er for et antal personer pr ark.
Personerne står i samme rækker på alle ark og overskrifterne står i de første to rækker.
Jeg vil gerne have et ark pr. person med data fra alle 3 ark samlet. Jeg har indtil videre benyttet noget vba-kode der kan splitte data op, men kan ikke få koden til at hente data fra de andre ark også.

håber nogen kan hjælpe :)
Avatar billede rashid Praktikant
02. februar 2012 - 10:11 #1
Option Explicit

Sub ParseItems()
'Jerry Beaucaire  (4/22/2010)
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

    Sheets("Samlet score").Select
    Range("A5:i37").Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    ActiveSheet.Name = "Data"
    Range("G2:I33").Select
    Selection.NumberFormat = "0.00"
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft

'Sheet with data in it
  Set ws = Sheets("Data")

'Path to save files into, remember the final\
    SvPath = "U:\Testresultater\samletscore\"
   
'Speed up macro execution
  Application.ScreenUpdating = False
DeleteEmptyRows Range("A1:D133")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:H1"
 
'Choose column to evaluate from, column A = 1, B = 2, etc.
  vCol = Application.InputBox("What column to split data by? " & vbLf _
        & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
  If vCol = 0 Then Exit Sub

'Spot bottom row of data
  LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row



'Get a temporary list of unique values from column A
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
       
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
       
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
        ActiveWorkbook.Close False
       
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

Sub DeleteEmptyRows(DeleteRange As Range)
' Deletes all empty rows in DeleteRange
' Example: DeleteEmptyRows Selection
' Example: DeleteEmptyRows Range("A1:D100")
Dim rCount As Long, r As Long
    If DeleteRange Is Nothing Then Exit Sub
    If DeleteRange.Areas.Count > 1 Then Exit Sub
    With DeleteRange
        rCount = .Rows.Count
        For r = rCount To 1 Step -1
            If Application.CountA(.Rows(r)) = 0 Then
                .Rows(r).EntireRow.Delete
            End If
        Next r
    End With
End Sub
Avatar billede rashid Praktikant
19. september 2014 - 11:27 #2
lukker
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