Marko til opsplitning af regneark i flere filer

Kan man få et eksempel på en række, og hvilken kolonne står leverandørnummer i. ?

tjek lige dine gamle spørgsmål
http://www.eksperten.dk/list.phtml?sort=&order=DESC&status_1=on&status_2=on&spm_creator=sendell&spm_part=&spm_answer=&find=&engine=exp

XXX1113076
XXX1113077
XXX1113078
XXX1113079

Kolonne A er varenumre. Dem er der så ca. 16000 af. Som ovenfor
Kolonne E er leverandørnavn.

Er det muligt at tilføje flere kolonner til den færdige fil? Der er i alt 94 kolonner i den store fil og der er nogen af kolonnerne jeg gerne vil have med i de små filer.

Beklager jeg ikke lige havde fået lukket de andre. De er lukket nu.

du kan prøve at køre denne makro.
Du blive spurgt om start af dataområde. Det er øverste, venstre celle i dit område.
Index-kolonnen er kolonne E med leverandørnavnene.

Makroen er ikke optimeret til dit brug og medtager derfor alle sammenhængende kolonner

Option Base 1
Option Explicit

Sub Filter_Distribute()
'by Tommy Bak
'*** Dim vars
  Dim iX As Long
  Dim Uniq_Matrix As New Collection
  Dim TempMatrix
  Dim varItem
  Dim wshStart As Worksheet
  Dim rngStart As Range
  Dim rngIndex As Range
  Dim lngFilterCol As Long
  Dim lngCnt1 As Long
  Dim lngCnt2 As Long

  '*** Initializing sequence
  Set wshStart = ActiveSheet
  With Application
      Set rngStart = .InputBox("Starting cell of data-area", Type:=8)
      Set rngIndex = .InputBox("Index-Column", Type:=8)
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
  End With

  '*** Fill all data of Index-Column into an array
  With rngIndex
      TempMatrix = Range(Cells(.Row, .Column), Cells(65536, .Column).End(xlUp).Address)
      lngFilterCol = .Column - rngStart.Column + 1
  End With

  '*** Fill Uniq_Matrix with Unique values
  On Error Resume Next
  For iX = 2 To UBound(TempMatrix)
      Uniq_Matrix.Add TempMatrix(iX, 1), CStr(TempMatrix(iX, 1))
  Next iX
  On Error GoTo cleanup

  '*** Dismis TempMatrix to regain memory
  Set TempMatrix = Nothing
  lngCnt1 = Uniq_Matrix.Count

  '*** Make new sheets or clear contents of old sheets
  For Each varItem In Uniq_Matrix
      If SheetExists(ActiveWorkbook.Worksheets, CStr(varItem)) Then
        'Sheets(CStr(varItem)).Range("A1").CurrentRegion.ClearContents
      Else
        Sheets.Add
        ActiveSheet.Name = varItem
      End If
  Next

  '*** Set autofilter on all unique item and
  '*** copy the result to corresponding sheet
  For Each varItem In Uniq_Matrix
      With rngStart.Cells(1, 1)
        .AutoFilter Field:=lngFilterCol, Criteria1:=varItem
        .CurrentRegion.Copy
      End With
      Sheets(varItem).Range("A1").PasteSpecial (xlPasteValues)
      'Sheets(varItem).Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
      Application.DisplayAlerts = False
      Sheets(varItem).Move
      ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & varItem & ".xls", FileFormat:=xlNormal
      ActiveWorkbook.Close savechanges:=False
      wshStart.Activate
      Application.DisplayAlerts = True

      lngCnt2 = lngCnt2 + 1
      Application.StatusBar = lngCnt2 & " af " & lngCnt1
  Next

cleanup:
  '***  Cleanup and finish the job
  rngStart.AutoFilter
  With Application
      .StatusBar = False
      .CutCopyMode = False
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
  End With
  Set Uniq_Matrix = Nothing
End Sub

Function SheetExists(Coln As Object, Item As String) As Boolean
  Dim Obj As Object
  On Error Resume Next
  Set Obj = Coln(Item)
  SheetExists = Not Obj Is Nothing
End Function

Stå på arket med de 16000 data og kør så makroen

Sub Makro1()
    Dim RW As Long, WB As Object, OK As Boolean, aWB As Object, C As Range, NWB As Object, Navn As String
Set aWB = ActiveSheet

    RW = aWB.Range("E65536").End(xlUp).Row
    For Each C In aWB.Range("E2:E" & RW).Cells
    Navn = C.Value
        OK = False
        For Each WB In ActiveWorkbook.Worksheets
            If WB.Name = C Then OK = True
        Next
        If Not OK Then
            Worksheets.Add
          ActiveSheet.Name = Navn
        End If
        aWB.Rows(C.Row & ":" & C.Row).Copy Worksheets(Navn).Range("A65536").End(xlUp).Offset(1, 0)
    Next
End Sub

Til at splitte arkene ud i selvstændige mappe bruges denne, du skal igen Stå på arket med de 16000 data og kør så makroen

Public Sub Gem_som_separate_Mapper()
Dim WB As Object, WSN As String, X As String, Sti As String
Sti = ActiveWorkbook.Path
Application.ScreenUpdating = False
WSN = ActiveSheet.Name
    For Each WB In ActiveWorkbook.Worksheets
    X = WB.Name
        If X <> WSN Then
            Sheets(X).Move
            ActiveWorkbook.SaveAs Filename:= _
                                  Sti & "\" & X & ".xls", FileFormat:=xlNormal, _
                                  Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
                                  CreateBackup:=False
            ActiveWindow.Close
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Bak dit svar var det jeg skulle bruge. Tak for det. Læg et svar og jeg giver dig point

ok :-)

Kig evt. på mit nye spørgsmål som er en opfølger på denne makro. Der er ekstra 200 point at hente