Macro Save File in Current Folder

A

Aliluz82

New Member
Joined
Jun 17, 2017
Messages
5
Hi!!:)

Please I need your help

I have the next code which generates .ics file.

I need in advance to sort by date in column B. Can you put that in the code?
Also I need to to save the file ics in the current directory

Can you help me modify this code?
Thanks in advance

Code: 
Sub Calendario()





Range("A2").Activate


'Range("A1").End(xlDown).Activate
FilaInicio = ActiveCell.Row
ActiveCell.End(xlDown).Activate
FilaFin = ActiveCell.Row


ActiveCell.End(xlToRight).Activate
ColumnaFin = ActiveCell.Column
FilasNoVacias = FilaFin - FilaInicio + 1


'Call Ordenar(FilaInicio, FilaFin, ColumnaFin)


Range("A2").Activate


'FilasNuevas = FilasNoVacias * ColumnaFin


Dim CeldaMatriz As Double


Dim Matriz() As Variant










ReDim Matriz(1 To ColumnaFin + 1, 1 To FilasNoVacias) As Variant


Dim Hora As Date
Hora = "08:30:00"


For i = 0 To FilasNoVacias - 1


  FilMatriz = FilMatriz + 1
  
     For q = 0 To ColumnaFin
            
         ColMatriz = ColMatriz + 1
                      
         If q < ColumnaFin Then
         
     
         
                          
         Matriz(ColMatriz, FilMatriz) = ActiveCell.Offset(i, q).Value
       
         Else
         
             
         
              If FilMatriz > 1 Then
             
                                      
                                      
                       If Matriz(2, FilMatriz) = Matriz(2, FilMatriz - 1) Then
                   
                       Hora = Hora + "00:30:00"
                       Else
                       Hora = "08:30:00"
                       End If
                           
              End If
         Matriz(ColMatriz, FilMatriz) = Hora
         End If
               


               
     Next q
  
   
   ColMatriz = 0 'Resetea la columna


Next i


Application.DisplayAlerts = False








Dim Usuario As Object
Set Usuarios = New Collection


For Each Usuario In Range("E" & FilaInicio & ":E" & FilaFin)
    
   
    
    On Error Resume Next
    
    Usuarios.Add Usuario.Value, CStr(Usuario.Value)
        'CStr convierte valores en texto
    On Error GoTo 0
    Next Usuario








CeldaActiva = 37




For Individuo = 1 To Usuarios.Count


NombreHoja = Usuarios(Individuo)


 Worksheets.Add.Name = NombreHoja
 
 Sheets(NombreHoja).Activate


 Range("$A$1").Value = "BEGIN:VCALENDAR"
 Range("$A$2").Value = "CALSCALE:GREGORIAN"
 Range("$A$3").Value = "METHOD:PUBLISH"
 Range("$A$4").Value = "X-WR-TIMEZONE:America/Argentina/Buenos_Aires"
 Range("$A$5").Value = ""
 Range("$A$6").Value = "BEGIN:VTIMEZONE"
 Range("$A$7").Value = "TZID:Etc/UTC"
 Range("$A$8").Value = "X-LIC-LOCATION:Etc/UTC"
 Range("$A$9").Value = "BEGIN:STANDARD"
 Range("$A$10").Value = "TZOFFSETFROM:+0000"
 Range("$A$11").Value = "TZOFFSETTO:+0000"
 Range("$A$12").Value = "TZNAME:GMT"
 Range("$A$13").Value = "DTSTART:19700101T000000"
 Range("$A$14").Value = "END:STANDARD"
 Range("$A$15").Value = "END:VTIMEZONE"
 Range("$A$16").Value = "BEGIN:VTIMEZONE"
 Range("$A$17").Value = "TZID:America/Araguaina"
 Range("$A$18").Value = "X-LIC-LOCATION:America/Araguaina"
 Range("$A$19").Value = "BEGIN:STANDARD"
 Range("$A$20").Value = "TZOFFSETFROM:-0300"
 Range("$A$21").Value = "TZOFFSETTO:-0300"
 Range("$A$22").Value = "TZNAME:-03"
 Range("$A$23").Value = "DTSTART:19700101T000000"
 Range("$A$24").Value = "END:STANDARD"
 Range("$A$25").Value = "END:VTIMEZONE"
 Range("$A$26").Value = "BEGIN:VTIMEZONE"
 Range("$A$27").Value = "TZID:America/Argentina/Buenos_Aires"
 Range("$A$28").Value = "X-LIC-LOCATION:America/Argentina/Buenos_Aires"
 Range("$A$29").Value = "BEGIN:STANDARD"
 Range("$A$30").Value = "TZOFFSETFROM:-0300"
 Range("$A$31").Value = "TZOFFSETTO:-0300"
 Range("$A$32").Value = "TZNAME:-03"
 Range("$A$33").Value = "DTSTART:19700101T000000"
 Range("$A$34").Value = "END:STANDARD"
 Range("$A$35").Value = "END:VTIMEZONE"
 Range("$A$36").Value = ""


 Range("A37").Activate








For Listado = 1 To FilaFin - FilaInicio + 1


  'MsgBox ("Registro = (" & Listado & ") " & Matriz(5, Listado) & " / Usuario = " & Usuarios(Individuo))
  
  
    If Matriz(5, Listado) = Usuarios(Individuo) Then
               
               NumRegistro = NumRegistro + 1
          
    






 ActiveCell.Offset(1, 0).Activate
 ActiveCell.Offset(1, 0).Value = "BEGIN:VEVENT"


 NuevaFecha = Format(Matriz(2, Listado), "yyyymmdd")
 Hora = Matriz(6, Listado)


 Dim NuevaHora As String
 NuevaHora = Replace(Hora, ":", "")


 ActiveCell.Offset(2, 0).Value = "DTSTART:" & NuevaFecha & "T" & NuevaHora & "Z"
 'ActiveCell.Offset(3, 0).Value = "DTSTAMP:20170805T212741Z"
 ActiveCell.Offset(4, 0).Value = "DESCRIPTION: " & Matriz(3, Listado) & " - " & Matriz(4, Listado)
 ActiveCell.Offset(5, 0).Value = "SUMMARY: " & Matriz(3, Listado) & " - " & Matriz(4, Listado) & " (" & Matriz(3, Listado) & ")"
 ActiveCell.Offset(6, 0).Value = ""
 ActiveCell.Offset(7, 0).Activate






 ActiveCell.Offset(1, 0).Value = "BEGIN: VALARM"
 ActiveCell.Offset(2, 0).Value = "ACTION: DISPLAY"
 ActiveCell.Offset(3, 0).Value = "DESCRIPTION: " & Matriz(3, Listado) & " - " & Matriz(4, Listado) & " (" & Matriz(3, Listado) & ")"
 ActiveCell.Offset(4, 0).Value = "TRIGGER: P0D"
 ActiveCell.Offset(5, 0).Value = ""


 ActiveCell.Offset(6, 0).Value = "END:VALARM"
 ActiveCell.Offset(7, 0).Value = "END:VEVENT"
 ActiveCell.Offset(8, 0).Value = ""
 ActiveCell.Offset(9, 0).Activate


End If


Next Listado


ActiveCell.Offset(1, 0).Value = "END:VCALENDAR"


 ActiveSheet.Copy
 Dim Ruta As String
 Ruta = "C:\Ali\" & NombreHoja & ".ics"
 ActiveWorkbook.SaveAs Filename:=Ruta, FileFormat:=xlText
 Application.Workbooks(NombreHoja & ".ics").Close
 Sheets(NombreHoja).Delete




 
Next Individuo


Application.DisplayAlerts = True




End Sub


Sub Calendario2()






Range("A2").Activate


FilaInicio = ActiveCell.Row
ActiveCell.End(xlDown).Activate
FilaFin = ActiveCell.Row


ActiveCell.End(xlToRight).Activate
ColumnaFin = ActiveCell.Column
FilasNoVacias = FilaFin - FilaInicio + 1




Range("A2").Activate




Dim CeldaMatriz As Double


Dim Matriz() As Variant










ReDim Matriz(1 To ColumnaFin + 1, 1 To FilasNoVacias) As Variant


Dim Hora As Date
Hora = "08:30:00"


For i = 0 To FilasNoVacias - 1


  FilMatriz = FilMatriz + 1
  
     For q = 0 To ColumnaFin
            
         ColMatriz = ColMatriz + 1
                      
         If q < ColumnaFin Then
         
         
         
                          
         Matriz(ColMatriz, FilMatriz) = ActiveCell.Offset(i, q).Value
       
         Else
         
              If FilMatriz > 1 Then
                                      
                                      
                       If Matriz(2, FilMatriz) = Matriz(2, FilMatriz - 1) Then
                       Hora = Hora + "00:30:00"
                       Else
                       Hora = "08:30:00"
                       End If
                           
              End If
         Matriz(ColMatriz, FilMatriz) = Hora
         End If
               


               
     Next q
  
   
   ColMatriz = 0 'Resetea la columna


Next i


Application.DisplayAlerts = False




Dim Usuario As Object
Set Usuarios = New Collection


For Each Usuario In Range("E" & FilaInicio & ":E" & FilaFin)
    
    
    On Error Resume Next
    
    Usuarios.Add Usuario.Value, CStr(Usuario.Value)
    On Error GoTo 0
    Next Usuario




CeldaActiva = 37




For Individuo = 1 To Usuarios.Count


NombreHoja = Usuarios(Individuo)


 Worksheets.Add.Name = NombreHoja
 
 Sheets(NombreHoja).Activate


 Range("$A$1").Value = "BEGIN:VCALENDAR"
 Range("$A$2").Value = "CALSCALE:GREGORIAN"
 Range("$A$3").Value = "METHOD:PUBLISH"
 Range("$A$4").Value = "X-WR-TIMEZONE:America/Argentina/Buenos_Aires"
 Range("$A$5").Value = ""
 Range("$A$6").Value = "BEGIN:VTIMEZONE"
 Range("$A$7").Value = "TZID:Etc/UTC"
 Range("$A$8").Value = "X-LIC-LOCATION:Etc/UTC"
 Range("$A$9").Value = "BEGIN:STANDARD"
 Range("$A$10").Value = "TZOFFSETFROM:+0000"
 Range("$A$11").Value = "TZOFFSETTO:+0000"
 Range("$A$12").Value = "TZNAME:GMT"
 Range("$A$13").Value = "DTSTART:19700101T000000"
 Range("$A$14").Value = "END:STANDARD"
 Range("$A$15").Value = "END:VTIMEZONE"
 Range("$A$16").Value = "BEGIN:VTIMEZONE"
 Range("$A$17").Value = "TZID:America/Araguaina"
 Range("$A$18").Value = "X-LIC-LOCATION:America/Araguaina"
 Range("$A$19").Value = "BEGIN:STANDARD"
 Range("$A$20").Value = "TZOFFSETFROM:-0300"
 Range("$A$21").Value = "TZOFFSETTO:-0300"
 Range("$A$22").Value = "TZNAME:-03"
 Range("$A$23").Value = "DTSTART:19700101T000000"
 Range("$A$24").Value = "END:STANDARD"
 Range("$A$25").Value = "END:VTIMEZONE"
 Range("$A$26").Value = "BEGIN:VTIMEZONE"
 Range("$A$27").Value = "TZID:America/Argentina/Buenos_Aires"
 Range("$A$28").Value = "X-LIC-LOCATION:America/Argentina/Buenos_Aires"
 Range("$A$29").Value = "BEGIN:STANDARD"
 Range("$A$30").Value = "TZOFFSETFROM:-0300"
 Range("$A$31").Value = "TZOFFSETTO:-0300"
 Range("$A$32").Value = "TZNAME:-03"
 Range("$A$33").Value = "DTSTART:19700101T000000"
 Range("$A$34").Value = "END:STANDARD"
 Range("$A$35").Value = "END:VTIMEZONE"
 Range("$A$36").Value = ""


 Range("A37").Activate






For Listado = 1 To FilaFin - FilaInicio + 1


  
  
    If Matriz(5, Listado) = Usuarios(Individuo) Then
               
               NumRegistro = NumRegistro + 1
          
    






 ActiveCell.Offset(1, 0).Activate
 ActiveCell.Offset(1, 0).Value = "BEGIN:VEVENT"


 NuevaFecha = Format(Matriz(2, Listado), "yyyymmdd")
 Hora = Matriz(6, Listado)


 Dim NuevaHora As String
 NuevaHora = Replace(Hora, ":", "")


 ActiveCell.Offset(2, 0).Value = "DTSTART:" & NuevaFecha & "T" & NuevaHora & "Z"
 'ActiveCell.Offset(3, 0).Value = "DTSTAMP:20170805T212741Z"
 ActiveCell.Offset(4, 0).Value = "DESCRIPTION: " & Matriz(3, Listado) & " - " & Matriz(4, Listado)
 ActiveCell.Offset(5, 0).Value = "SUMMARY: " & Matriz(3, Listado) & " - " & Matriz(4, Listado) & " (" & Matriz(3, Listado) & ")"
 ActiveCell.Offset(6, 0).Value = ""
 ActiveCell.Offset(7, 0).Activate




 ActiveCell.Offset(1, 0).Value = "BEGIN: VALARM"
 ActiveCell.Offset(2, 0).Value = "ACTION: DISPLAY"
 ActiveCell.Offset(3, 0).Value = "DESCRIPTION: " & Matriz(3, Listado) & " - " & Matriz(4, Listado) & " (" & Matriz(3, Listado) & ")"
 ActiveCell.Offset(4, 0).Value = "TRIGGER: P0D"
 ActiveCell.Offset(5, 0).Value = ""


 ActiveCell.Offset(6, 0).Value = "END:VALARM"
 ActiveCell.Offset(7, 0).Value = "END:VEVENT"
 ActiveCell.Offset(8, 0).Value = ""
 ActiveCell.Offset(9, 0).Activate


End If


Next Listado


ActiveCell.Offset(1, 0).Value = "END:VCALENDAR"


 ActiveSheet.Copy
 Dim Ruta As String
 Ruta = "C:\Ali\" & NombreHoja & ".ics"
 ActiveWorkbook.SaveAs Filename:=Ruta, FileFormat:=xlText
 Application.Workbooks(NombreHoja & ".ics").Close
 Sheets(NombreHoja).Delete




Next Individuo


Application.DisplayAlerts = True




End Sub


Thank You!!
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
You must log in or register to reply here.

Similar threads

T
  • Solved
Import iCal (ICS File) Data to Excel Table
Replies
5
Views
5K
Dan_W
D

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top