NEED HELP WITH THIS VBA CODE (SPLIT BY ROWS)

[JonnySpain]

Hello to everyone!

Im getting a good brain meltdown with this one, i have been copy pasting code for a while now to get closer to my goal.
I want to split Data from ROWS into diferent Sheets and then export them as PDF, so far so good.

I have an aplication input box in wich i tell the number of rows to split...... but i would prefer to split every x rows (IF the SUMM of the Value in colum L reaches over 360 minutes, basically i want to tell the VBA to create one new Sheet every time the row count in colum L hits 360 or over and of course the last sheet will have less so i need If and Else .... i hope i explain good enough.

I will post and see if someone can crack it!

You will see that when u run the macro with the test data i left copied in colum L will apear certain values(numerical but they are minutes).

Here goes the code

Sub Split_Sheet_based_on_rows()

Dim data_range As Range
Dim start_row As Range
Dim split_row As Integer
Dim main_sheet As Worksheet
Dim camareras_disponibles As Range


Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range

Set sht = Worksheets("Servicios diarios Ama de Ll1")
Set StartCell = Range("A2")

On Error GoTo ErrorHandler


'ENCONTRAR ULTIMA FILA

'Refresh UsedRange
Worksheets("Servicios diarios Ama de Ll1").UsedRange

'Find Last Row
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'ORDENAR POR Nº APARTAMENTO DE MENOR A MAYOR

Columns("D:D").Select
Range("D2").Activate
ActiveWorkbook.Worksheets("Servicios diarios Ama de Ll1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Servicios diarios Ama de Ll1").Sort.SortFields.Add _
Key:=Range("D2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Servicios diarios Ama de Ll1").Sort
.SetRange sht.Range("A2:K" & LastRow)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select




'Asignamos tiempos a Servicios

Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]='BASE Y VARIABLES'!R2C16,'BASE Y VARIABLES'!R2C18,IF(RC[-3]='BASE Y VARIABLES'!R3C16,'BASE Y VARIABLES'!R3C18,IF(RC[-3]='BASE Y VARIABLES'!R4C16,'BASE Y VARIABLES'!R4C18,IF(RC[-3]='BASE Y VARIABLES'!R5C16,'BASE Y VARIABLES'!R5C18,IF(RC[-3]='BASE Y VARIABLES'!R6C16,'BASE Y VARIABLES'!R6C18,IF(RC[-3]='BASE Y VARIABLES'!R7C16,'BASE Y VARIABLES'!R7C18,IF(RC[-3]='BASE Y VARIABLES'!R8C16,'BASE Y VARIABLES'!R8C18,IF(RC[-3]='BASE Y VARIABLES'!R9C16,'BASE Y VARIABLES'!R9C18,IF(RC[-3]='BASE Y VARIABLES'!R10C16,'BASE Y VARIABLES'!R10C18,IF(RC[-3]='BASE Y VARIABLES'!R11C16,'BASE Y VARIABLES'!R11C18,0))))))))))"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L" & LastRow), Type:=xlFillDefault
Range("L2:L" & LastRow).Select

Range("O14").Select

' borraDatos que no son relevantes

Columns("A:A").Select
Selection.ClearContents
Columns("B:B").Select
Selection.ClearContents
Columns("C:C").Select
Selection.ClearContents
Columns("E:E").Select
Selection.ClearContents
Columns("G:G").Select
Selection.ClearContents
Columns("H:H").Select
Selection.ClearContents
Columns("K:K").Select
Selection.ClearContents



'Definir numero de camareras disponibles

xTitleId1 = "Camareras Disponibles"

Set camareras_disponibles = Range("M12")
camareras_disponibles = Application.InputBox("NºCamareras", xTitleId1, Type:=1)


'Reparto de Servicios

xTitleId = "Comfirmar Nº Servicios a realizar x Camarera"

Set data_range = Range("A2:K" & LastRow)
split_row = Application.InputBox("Nº Tareas x Camarera `Celda M17 marcada en amarillo´", xTitleId, Range("M17"), Type:=2)


'Borrar datos de tiempo antes de dividir

Columns("I:I").Select
Selection.ClearContents

'Reparto Hojas de Calculo y Exportar a PDF con Fecha del día
'QUEDA PENDIENTE AVERIGUAR SI SE PUEDE DEFINIR QUE NO ROMPA SERVIVIOS DEL MISMO Nº DE APARTAMENTO A LA HORA DE REPARTIR, IGUAL SE PUEDE SUSTITUIR HOJA DE CALCULO POR TABLA DINAMICA


Set main_sheet = data_range.Parent
Set start_row = data_range.Rows(1)

Application.ScreenUpdating = False
For i = 1 To data_range.Rows.Count Step split_row
resizeCount = split_row
If data_range.Rows.Count < split_row Then resizeCount = data_range.Rows.Count - 1
start_row.Resize(resizeCount).Copy

Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count)


Application.ActiveSheet.Range("A1").PasteSpecial

'Dar Estilo

Selection.Style = "Ausgabe"

'Borrar columnas vacias B C G y H

Range("B:B,C:C,G:G,H:H").Select

Selection.Delete Shift:=xlToLeft
Range("A1").Select

'ZONA TEST, CONVERTIR EN PDF
Dim ws As Worksheet
Dim sheetArray As Variant

'Capture the selected sheets
Set sheetArray = ActiveWindow.SelectedSheets
Current_Date = Date
'Loop through each selected worksheet
For Each ws In sheetArray

ws.Select

ws.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "/" & ws.Name & " Servicios a fecha " & Date & ".pdf"



Set start_row = start_row.Offset(split_row)
Next ws
'FIN ZONA TEST, CONVERTIR EN PDF
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True

'Borrar Datos Hoja Principal
MsgBox ("FIN! vea los PDF en la carpeta y que tenga un buen día")

Sheets("Servicios diarios Ama de Ll1").Select
Columns("A:L").Select
Selection.ClearContents
Sheets("Servicios diarios Ama de Ll1").Select
Range("A1").Select


'Cerrar Libro sin guardar cambios para su uso posterior

ActiveWorkbook.Close SaveChanges:=False


Exit Sub
ErrorHandler:
MsgBox "Datos introducidos estan mal o ha cancelado una ventanilla, recuerde definir el Nºde Camareras y Confirmar el Nº de Servicios. Vuelva a ejecutar la macro"
Exit Sub

End Sub

 

[DanteAmor]

Hi and welcome to MrExcel Board!

Try this. Copy all the code in a module and run the macro Split_Sheet_Based_On_Count

Option Explicit

Sub Split_Sheet_Based_On_Count()
  Dim lr As Long, i As Long, ini As Long
  Dim camareras_disponibles As Range
  Dim sh1 As Worksheet
  Dim nSum As Double
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Servicios diarios Ama de Ll1")
  
  'Ordenar por Nº apartamento de de menor a mayor
  lr = sh1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
  sh1.Range("A2:K" & lr).Sort sh1.Range("D2"), xlAscending, Header:=xlNo
  
  'Asignamos tiempos a Servicios
  With sh1.Range("L2:L" & lr)
    .Formula = "=IFERROR(VLOOKUP(I2,'BASE Y VARIABLES'!$P$2:$R$11,3,0),0)"
    .Value = .Value
  End With
  
  ' borraDatos que no son relevantes
  sh1.Range("A:C, E:E, G:H, K:K").ClearContents
  
  'Definir numero de camareras disponibles
  Set camareras_disponibles = sh1.Range("M12")
  camareras_disponibles = Application.InputBox("NºCamareras", "Camareras Disponibles", Type:=1)
  
  sh1.Range("I:I").ClearContents  'Borrar datos de tiempo antes de dividir
  
  'Reparto Hojas de Calculo y Exportar a PDF con Fecha del día
  ini = 2
  For i = 2 To lr
    nSum = nSum + sh1.Range("L" & i).Value
    If nSum >= 360 Then
      Call creaPDF(sh1, ini, i)
      ini = i
      nSum = 0
    End If
  Next
  If nSum < 360 Then Call creaPDF(sh1, ini, i)
  sh1.Range("A:L").ClearContents
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  MsgBox ("FIN! vea los PDF en la carpeta y que tenga un buen día")
End Sub

Sub creaPDF(sh1 As Worksheet, ini As Long, i As Long)
  sh1.Range("A" & ini & ":K" & i).Copy
  Sheets.Add after:=Sheets(Sheets.Count)
  With ActiveSheet
    .Range("A1").PasteSpecial
    .Range("B:B,C:C,G:G,H:H").Delete Shift:=xlToLeft
    sh1.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & .Name & " Servicios a fecha " & Format(Date, "dd-mm-yyyy") & ".pdf"
  End With
End Sub

------------------
Note Code Tag:
In future please use code tags when posting code.
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.

 

[JonnySpain]

Hello Dante,
first of all THANK YOU!

As soon as i can i will run it an check several data input, reading your code i see the diference between someone who knows what to do and me and my 40 hours tutorial knowledge XD.

I`ll post you a feedback ASAP

Thanks again

Jonny