Macro Data splitsen in nieuwe sheets met een andere sheetnaam

[Rus5ianguy]

Hallo,

ik had een klein vraagje, Ik was bezig met een macro bouwen die data splitst in nieuwe sheets. Wat die eigenlijk doet is als die in een bepaalde kolom dezelfde gegevens vindt maakt die voor diezelfde gegevens een aparte sheet. jammer genoeg komt t voor dat de gegevens langer zijn dat 31 karakters waardoor de sheetnaam zijn max overschrijd en wil daardoor het niet splitsen. hieronder vindt je de macro:

"Sub SplitDataNrows()
Dim N As Long, rw As Long, rw1 As Long, rw2 As Long, LR As Long, Titles As Boolean

If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, "Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, "Titles?") = vbYes Then Titles = True

With ActiveSheet
LR = .Range("B" & .Rows.Count).End(xlUp).Row

For rw = 1 + ---Titles To LR Step N
Sheets.Add
If Titles Then
.Rows(1).Copy Range("A1")
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
Else
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
End If
Next rw

.Activate
End With

Application.ScreenUpdating = False
Dim wkSt As String
Dim wkBk As Worksheet
wkSt = ActiveSheet.Name
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
Cells.EntireColumn.AutoFit
Next wkBk
Sheets(wkSt).Select
Application.ScreenUpdating = True

End Sub

Ik hoop dat iemand een oplossing weet zonder ***ools te gebruiken.

Alvast bedankt!

 

[OctaFish]

Wat zou je willen als oplossing? Dat hij de eerste 31 karakters neemt? Of een inputbox waarin je een correcte naam kunt intypen?

 

[Rus5ianguy]

Ik zou willen dat die de nieuwe sheets die aangemaakt worden een standaard naam kreg

Ik zou willen dat die de nieuwe sheets die aangemaakt worden een standaard naam kregen zoals blad 1 enz.. of sheet1

p.s. bedankt voor je reactie

 

[OctaFish]

Zou je een voorbeeldbestandje kunnen posten? Werkt altijd wat makkelijker als dat we eerst zelf een bestand moeten maken/aanpassen.

 

[Rus5ianguy]

dit is t bestand

Sub SplitDataNrows()
Dim N As Long, rw As Long, rw1 As Long, rw2 As Long, LR As Long, Titles As Boolean

If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, "Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, "Titles?") = vbYes Then Titles = True

With ActiveSheet
LR = .Range("B" & .Rows.Count).End(xlUp).Row

For rw = 1 + ---Titles To LR Step N
Sheets.Add
If Titles Then
.Rows(1).Copy Range("A1")
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
Else
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
End If
Next rw

.Activate
End With

Application.ScreenUpdating = False
Dim wkSt As String
Dim wkBk As Worksheet
wkSt = ActiveSheet.Name
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
Cells.EntireColumn.AutoFit
Next wkBk
Sheets(wkSt).Select
Application.ScreenUpdating = True

End Sub

 

[OctaFish]

Bij mij doet-ie het prima, al heb ik wel een overbodige actie bij jou verwijderd. En de naam van een variabele veranderd (Een Workbook (wkBk) is niet het hetzelfde als een WorkSheet (wkSht)

    For Each wkSht In ActiveWorkbook.Worksheets
        wkSht.Cells.EntireColumn.AutoFit
    Next wkSht

 

[Rus5ianguy]

nieuw reactie

en als je nou van de rij waar je de gegevens vandaaan haalt een ervan langer maakt dan 31 karakters wat gebeurt er dan. Bij mij splitst die hem niet. hij maakt wel een nieuwe sheet aan maar dan zonder gegevens

 

[Rus5ianguy]

Mijn excusses verkeerde code

Dit is de correcte

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

vcol =1, the number 1 is the column number that you want to split the data based on.
Set ws = Sheets("Sheet1"), Sheet1 is the sheet name that you want to apply this code.
title = "A1:C1", A1:C1 is the range of the title.