Comment diviser les données en plusieurs feuilles de calcul en fonction de la colonne dans Excel?
Supposons que vous ayez une feuille de calcul avec d'énormes lignes de données et que vous deviez maintenant diviser les données en plusieurs feuilles de calcul en fonction du Nom colonne (voir capture d'écran suivante), et les noms sont saisis au hasard. Vous pouvez peut-être les trier d'abord, puis les copier et les coller une par une dans d'autres nouvelles feuilles de calcul. Mais cela nécessitera votre patience pour copier et coller à plusieurs reprises. Aujourd'hui, je vais parler de quelques astuces rapides pour résoudre cette tâche.
Divisez les données en plusieurs feuilles de calcul en fonction de la colonne avec le code VBA
Si vous souhaitez fractionner les données en fonction de la valeur de la colonne rapidement et automatiquement, le code VBA suivant est un bon choix. Veuillez faire comme ceci:
1. Maintenez le ALT + F11 clés pour ouvrir le Microsoft Visual Basic pour applications fenêtre.
2. Cliquez insérer > Moduleet collez le code suivant dans la fenêtre Module.
Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub
3. Puis appuyez F5 pour exécuter le code, et une boîte de dialogue s'affiche pour vous rappeler de sélectionner la ligne d'en-tête, voir capture d'écran:
4. Et puis, cliquez OK bouton, et dans la deuxième boîte de dialogue, sélectionnez les données de colonne que vous souhaitez diviser en fonction, voir capture d'écran:
5. Puis clique OKet toutes les données de la feuille de calcul active sont divisées en plusieurs feuilles de calcul par la valeur de la colonne. Et les feuilles de calcul fractionnées sont nommées avec les noms des cellules fractionnées. Voir la capture d'écran:
Notes: Les feuilles de calcul fractionnées sont placées à la fin du classeur où se trouve la feuille de calcul principale.
Divisez les données en plusieurs feuilles de calcul en fonction de la colonne avec Kutools for Excel
En tant que débutant Excel, ce long code VBA est quelque peu difficile pour nous, et la plupart d'entre nous ne savent même pas comment modifier le code selon nos besoins. Ici, je vais vous présenter un outil multifonctionnel -Kutools pour Excel, il est Diviser les données L'utilitaire peut non seulement vous aider à diviser les données en plusieurs feuilles de calcul en fonction de la colonne, mais peut également diviser les données par nombre de lignes.
A Noter:Appliquer cette Diviser les données, tout d'abord, vous devez télécharger le Kutools pour Excel, puis appliquez la fonction rapidement et facilement.
1. Sélectionnez la plage de données que vous souhaitez fractionner.
2. Cliquez Kutools Plus > Feuille > Diviser les données, voir capture d'écran:
3. Dans le Diviser les données en plusieurs feuilles de calcul boîte de dialogue, vous devez:
1). Sélectionner Colonne spécifique option dans la Fractionner basé sur et choisissez la valeur de colonne sur laquelle vous souhaitez fractionner les données dans la liste déroulante. (Si vos données ont des en-têtes et que vous souhaitez les insérer dans chaque nouvelle feuille de calcul fractionnée, veuillez vérifier Mes données ont des en-têtes option.)
2). Ensuite, vous pouvez spécifier les noms de feuille de calcul fractionnés, sous Nouveau nom de feuille de calcul , spécifiez les règles de noms de feuille de calcul dans Règles liste déroulante, vous pouvez ajouter le Préfixe or Suffixe pour les noms de feuille également.
3). Clique le OK bouton. Voir la capture d'écran:
4. Désormais, les données sont divisées en plusieurs feuilles de calcul dans un nouveau classeur.
Kutools for Excel résout la plupart de vos problèmes et augmente votre productivité de 80%
Réutilisation: Insérer rapidement formules complexes, graphiques et tout ce que vous avez utilisé auparavant; Crypter les cellules avec mot de passe; Créer une liste de diffusion et envoyer des e-mails ...
Barre Super Formula (modifiez facilement plusieurs lignes de texte et de formule); Disposition de lecture (lire et modifier facilement un grand nombre de cellules); Coller dans la plage filtrée...
Fusionner les cellules / lignes / colonnes sans perdre de données; Contenu des cellules divisées; Combiner des lignes / colonnes en double... Empêcher les cellules en double; Comparer les gammes...
Sélectionnez Dupliquer ou Unique Lignes; Sélectionnez les lignes vides (toutes les cellules sont vides); Super Find et Fuzzy Find dans de nombreux classeurs; Sélection aléatoire ...
Copie exacte Plusieurs cellules sans changer la référence de formule; Créer automatiquement des références à plusieurs feuilles; Insérer des puces, Cases à cocher et plus encore ...
Extrait du texte, Ajouter du texte, Supprimer par position, Supprimer l'espace; Créer et imprimer des sous-totaux de pagination; Conversion entre le contenu et les commentaires des cellules...
Super filtre (enregistrer et appliquer des schémas de filtrage à d'autres feuilles); Tri avancé par mois / semaine / jour, fréquence et plus; Filtre spécial par gras, italique ...
Combiner des classeurs et des feuilles de travail; Fusionner les tableaux en fonction des colonnes clés; Diviser les données en plusieurs feuilles; Conversion par lots xls, xlsx et PDF...
Plus de 300 fonctionnalités puissantes. Prend en charge Office / Excel 2007-2019 et 365. Prend en charge toutes les langues. Déploiement facile dans votre entreprise ou organisation. Essai gratuit de 30 jours. Garantie de remboursement de 60 jours.
Hi, great time saver, thanks. I know it is an old post but hopefully someone can help.
My table needs splitting based on column 1, but column 1 contains dates and the result is that each new sheet doesnt contain any data. It creates the right amount of sheets but doesnt move any data. Any Ideas?
Hello, Carrington,
To split the data based on the date column, you should use the following vba code, but, this code is only applied to date column correctly, if your key column is normal data, please use the code in this article.
Sub parseData_Date()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xName As String
Dim xValue As String
Dim xArrFind As Variant
Dim xStrReplace As String
Dim xFNum As Integer
Dim xRg As Range
Set ws = Sheets("Master sheet")
xArrFind = Array(":", "\", "/", "?", "*", "[", "]")
xStrReplace = "_"
vcol = 1
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
On Error Resume Next
For i = 2 To lr
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
Set xRg = ws.Cells(i, vcol)
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
xValue = ""
xValue = myarr(i)
xValue = FormatDateTime(xValue)
xName = xValue
For xFNum = 0 To UBound(xArrFind)
xName = Replace(xName, xArrFind(xFNum), xStrReplace)
Next xFNum
ws.Range(title).AutoFilter field:=vcol, Criteria1:=xValue & ""
If Not Evaluate("=ISREF('" & xName & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = xName & ""
Else
Sheets(xName & "").Move After:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(xName & "").Range("A1")
Sheets(xName & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
hi,I 've to do un upgrade in this code. More specific, i have a Dataset("Data") to split in multiple sheet and this code it's good to me. But in my new sheet i don't want all column from the orignal data but only specific column. How can i do?
If you have tens of thousands rows data need to be split, I will recommend you to use the Kutools for Excel's Split Data feature, with this feature, you can achieve the job quickly and easily. You can download and free trail 30 days. Please try, thank you!
Is there anyway to do this in a way that will maintain the page layout/print set up? header, footer, gridlines, repeat rows, lanscape, narrow margins, fit columns on page, etc?
Nothing happens. I run the code, it prompts me for the header & column info, I input it, and then nothing. Not even an error to point me in the right direction.
Thank you so much for this code it has helped me over the last few months amazingly.
However, since last month this code has not working for me. It only creates sheets with the name but data, format as well as headers are not carrying over.
I have changed my computer though not sure if this has to do something with it. I have been using the same code and steps as specified above.
Hi there,
Thank you so much for this post. It is really very helpful.
I have another situation that requires me to split salary data per department so that each manager will receive a workbook for their team only. I do not mail these out to managers, I simply safe it in their respective folder on the server.
I use this code, but this code does not split the worksheet into separate files. Can you please help me to modify this code so that it will create separate workbooks for me in the same directory as the master sheet?
Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim Planners As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set Planners = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set Planners = RemoveDuplicates(Planners)
Call CreateSheets(Planners, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(Planners As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "Planners"
Sheets("Planners").Activate
On Error GoTo 0
Planners.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "Planners"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(Planners As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long
For Each Unique In Planners
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=Unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = Unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next Unique
End Sub
Hello, Jaco, To split the data into multiple separate workbooks based on the column value, the code in the following article may help you: https://www.datanumen.com/blogs/2-fast-means-to-split-an-excel-worksheets-contents-into-multiple-workbooks-based-on-a-specific-column/
Hey, i really need some help. 1. first i want to to split based on value and after that to split per 1k based on value before. 2. After split per 1k, i need to save as those files to xls.
This macro has come in handy more times than i can count, Does anyone have a work around for these two issues? Any help is appreciated!
1. make the Macro work form a worksheet that is formatted as a table and maintain the same formatting in the new worksheets? I have been able to use this macro when the worksheet is not formatted.
2. split columns that Include blank cells from the original worksheet to the new worksheets. My original data has some empty cells, that need to remain empty, when i use this macro, the divided columns exclude the data that had an empty cell in the column that was split.
This macro has come in handy more times than i can count, Does anyone have a work around for these two issues? Any help is appreciated!
1. make the Macro work form a worksheet that is formatted as a table and maintain the same formatting in the new worksheets? I have been able to use this macro when the worksheet is not formatted.
2. split columns that Include blank cells from the original worksheet to the new worksheets. My original data has some empty cells, that need to remain empty, when i use this macro, the divided columns exclude the data that had an empty cell in the column that was split.
Hey everyone. I am completely new to VBA. I have an account receivable data in an excel sheet and there are multiple column. One column mention the invoice no and the other mentions the department responsible for that invoice. I have tried this code, it split the column by department into multiple sheets but it does not include the invoice no. I have a big list of data and I don't to want copy and paste the data, can someone please help me. Thanks
The vba code is not working if the column values to split on has a length of 26. If I manually change it to 12 it works. Is there a reason for it. I understand that excel worksheet name cannot exceed 30 characters but here the length is 26 but it does not work. Can you please help me understand this. Thanks.
Hello,
Thank you for your comment, yes, as you said, the above vba code is not worked correctlly for cell values which text length are much longer, but, here, you can apply our product, Kutools for Excel, with its Split Data feature, you can achieve this job quickly and easily. You can download and free trail 30 days. Please try, thank you!
thank you very much, it helped me a lot in my work. However, is there a way to have the macro create a separate spreadsheet for each new tab instead of just adding a tab into the current worksheet? Thanks!
How can I make it to automatically choose a smaller name for the sheet instead of skipping an entry and returning sheet 4, sheet 5 etc.
E.G: I am using this amazing code to dissect my excel sheet, but some entries have a long name which exceeds the sheet name count, instead of using all 31 symbols that are allowed, it cancels the filtering and returns sheet 4 instead.
This code is brilliant. It does exactly what I need. Only, I don't know how to change the code so that the data in the rows, all starting with the same letter, should go on the same worksheet, instead of each getting its own worksheet. I have 1000 rows of data, some starting with "L", or "K"or "F" and then a number. It sorts the data each to its own sheet, I want all the "L" cells' data on one sheet and all the"K" data on one sheet. Can someone please help me. I don't underwstand coding that good
Add a column and pull the first character from the cell with L+ the number or K+ the number. Assume your key is in cell A2, use the formula =left(A2,1) to pull the first character into your new column. Use this column to separate data to its own sheet.
Thank you MP, I will definitely try that. I'm new to coding and still trying to figure it out as I go. But it's crunch time and i need the program to work ASAP. For now I'm just struggling a bit. Lol
Hello, ShiroKuro,
If there are large data in your worksheet, I recommend Kutools for Excel's Split Data feature for you, you can download it and free trial 60-day!
Please try, thank you!
Great script! Could someone please help as I need to just add "Class-C" at the end of each new worksheet's name that is created after running this. For Eg. Lucy-Class C; Emily Class C; and so on. Would really appreciate your help here.
just add a column and concatenate the Name and the "-Class C" field and use that as the column to split on instead of the Name column, then you can hide the column if you want
Hello, Aditya,
Here, I recommend Kutools for Excel's Split Data feature for you, you can add the prefix or suffix text easily in the dialog box as you need.
You can download the tool and free trial 60-day.
Please try, thank you!
Great Script, thanks! What do I have to do to set the header row range and column to use for grouping/splitting within the script? I know it is more elegant to use selectable parameters but for my use case it is always the same. As I do know nothing about VBA, any little hint is appreciated :-) Best, Katharina
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
This formula is great, works perfectly for me.
I want to split out data based on a location, which is in column 1. Which this does.
However, is it possible to also split out based on column 2, for example. Built and Not Built. So a secondary condition also?
can someone help please im using this but i keep getting to many columns. i have to keep deleting rows every time i use this.
This is what im using
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:AN1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Thanks for VBA, it works great. In addition to that question, I have column which is dependent. So when i select some value my column values get changed hence I need vba solution to replace earlier split worksheet to replace with new value of columns. Can anyone help me out.?
Effectively, this code does work great. I wrote an additional code so that I could get subtotal on certain columns but it has not worked great. So I tried running the subtotals from the master list, but afterwards when I use this macro it create a whole new tab for the Grand total row. So I am getting two two tabs per split. the first one is fine because it splits with the grand totals, but then creates a second one with just the grand total row. Any help as to how to modify this.
This is the code that I am currently using:
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 3
Set ws = Sheets("Master sheet")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:R1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Hi, This VBA worked great on my first attempt. However, when repeating the process with a new set of data, the sheets are splitting into Product names, but the data in each sheet still shows all data. I can't understand why it worked first time though. Can anyone help please. Thanks
This code is brilliant - Thank you. Just one thing - its splitting the data as I need it too but amongst creating the relevant sheets its creating blank sheets too.
Thanks for excellent & brilliant code. I came across a bug, if field name is too long, the new sheet is not created. It should be like that the new sheet may be named with the maximum number of characters allowed. Regards,
To anyone having issues with long sheet names (ie Sheet Names greater than 30 characters), replace:
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
with
Dim sheetName As String For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
' Replace the below assignment to sheetName as you wish
sheetName = Left(CStr(i - 1) & "_" & myarr(i), 30) If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = sheetName Else
Sheets(sheetName).Move after:=Worksheets(Worksheets.Count) End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(sheetName).Range("A1") Sheets(sheetName).Columns.AutoFit
Next
This essentially limits the Sheet Name to legal limits of 30 characters. If you do not like the way the sheet is named, replace sheetName's assignment whatever you would like, keeping in mind that no two sheets can have the exact same name and must also be 30 characters or less.
You can also remove the filtering that lingers at the end of the execution by adding this line just before "End Sub"
The codes works perfectly, only trouble is that it does not separate columns when the text is too long, I have text with 40 characters and I get an empty "sheet2", every other text gets sorted.
Any ideas on how to fix it? I've already tried changin variable and placed them as Long, however I am not sure I fully understand the program. all this for the VBA option.
I need a macro for following condition
suppose i have customer excel file in which first 7 rows is for header so, from 8th row records are start
i need to split rows of 500 record each in one file and save them with name customer1,customer2,customer3,........
suppose i have customer file of 2540 records so it split in
customer1 which have header rows with record starts from 8th row to 507th row
customer2 which have header rows with record starts from 508th row to 1007th row
customer3 which have header rows with record starts from 1008th row to 1507th row
customer4 which have header rows with record starts from 1508th row to 2007th row
customer5 which have header rows with record starts from 2008th row to 2507th row
customer6 which have header rows with record starts from 2508th row to 2540th row
Hi, guys,
If your worksheet data contains multiple header rows, the below VBA code can solve your prolem, please try it.
Sub Parse_data_0213()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub
