La séparation des données et de les placer dans des feuilles de calcul Excel VBA

Si vous souhaitez enregistrer une macro pour voir ce qui se passe, suivez ces étapes:

1. Allumez l'enregistreur de macro
2. De trier vos données par nom
3. De copier les données de la première nom
4. De le coller sur une autre feuille (ajoutez une feuille si vous avez besoin d'un autre)
5. Nom de la feuille
6. Répétez l'opération pour le prochain nom

J'ai également écrit un code que vous pouvez utiliser pour commencer. Pour que cela fonctionne, vous avez besoin de nom de l'onglet données "MasterList". Le code trie les lignes sur MasterList par nom, puis pour chaque nom dans la liste, crée une nouvelle feuille et copie les données appropriées à la nouvelle feuille, en répétant le processus jusqu'à ce que tous les noms ont été copiés sur de nouvelles feuilles.

Ajouter ce code dans un module et d'exécuter le DispatchTimeSeriesToSheets procédure.

Sub DispatchTimeSeriesToSheets()
Dim ws As Worksheet
Set ws = Sheets("MasterList")
Dim LastRow As Long
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:C" & LastRow).Sort Key1:=ws.Range("A1"), Key2:=ws.Range("B1")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim rng As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set rng = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In rng
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
Next
' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
name As String)
Dim tgt As Worksheet
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
Set tgt = Sheets(name)
' copy header row from src to tgt
tgt.Range("A1:C1").Value = src.Range("A1:C1").Value
' copy data from src to tgt
tgt.Range("A2:C" & Last - Start + 2).Value = _
src.Range("A" & Start & ":C" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Worksheet
SheetExists = True
On Error Resume Next
Set ws = Sheets(name)
If ws Is Nothing Then
SheetExists = False
End If
End Function

OriginalL'auteur Jon Crowell