Posts by patel

Sub a()
LR = Cells(Rows.Count, "M").End(xlUp).Row
For r = 2 To LR
  If Cells(r, "M") = "" Then
    Range("E" & r & ":N" & r).Value = Range("C" & r + 1 & ":L" & r + 1).Value
    Rows(r + 1).Delete
  End If
  If Len(Cells(r, "O").Value) > 1 Then
  Stop
    Cells(r, "D").Delete (xlShiftToLeft)
  End If
  
Next
End Sub

Private Sub CommandButton1_Click()
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
Dim SumOfI As Double ' <<<<<<<<<<< changed
Dim yourPassword As String
 
'yourPassword = "Hello!2"
 
 
For Each ws2 In ActiveWorkbook.Worksheets
    ws2.Unprotect Password:=yourPassword
Next ws2
 
LastRow = Cells(Rows.Count, "A").End(xlUp).Row ' <<<<<<<<<<< changed
 'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
Set My_Range = Range("A1:I" & LastRow)
My_Range.Parent.Select
 
 
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
    MsgBox "Sorry, not working when the workbook or worksheet is protected", _
    vbOKOnly, "Copy to new workbook"
    Exit Sub
End If
 
 
 'This example filters on the first column in the range(change the field if needed)
 'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
 
 
 'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
 
 
 'Set the file extension/format
 
If ActiveWorkbook.FileFormat = 52 Then
    FileExtStr = ".csv": FileFormatNum = 6
Else
    FileExtStr = ".csv": FileFormatNum = 6
     
End If
 
 
 'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
 
 
 'Delete the sheet SMLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("SMLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
 
 
 ' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "SMLogSheet"
 
 
 'Fill in the path\folder where you want the new folder with the files
 
MyPath = Application.DefaultFilePath
 
 
 'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If
 
 
 'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
 
 
With ws2
     'first we copy the Unique data from the filter field to ws2
    My_Range.Columns(FieldNum).AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=.Range("A3"), Unique:=True
     
     
     'loop through the unique list in ws2 and filter/copy to a new sheet
    Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    For Each cell In .Range("A4:A" & Lrow)
         
         
         'Filter the range
        My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
        Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
         
         
         'Check if there are no more then 8192 areas(limit of areas)
        CCount = 0
        On Error Resume Next
        CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
        .Areas(1).Cells.Count
        On Error GoTo 0
        If CCount = 0 Then
            MsgBox "There are more than 8192 areas for the value : " & cell.Value _
            & vbNewLine & "It is not possible to copy the visible data." _
            & vbNewLine & "Tip: Sort your data before you use this macro.", _
            vbOKOnly, "Split in worksheets"
        Else
             'Add new workbook with one sheet
            Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
             
             
             'Copy/paste the visible data to the new workbook
            My_Range.SpecialCells(xlCellTypeVisible).Copy
            With WSNew.Range("A1")
                 ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                 ' Remove this line if you use Excel 97
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
             'Sum the values in column
            SumOfI = Application.Sum(Range("I2:I" & LastRow)) ' <<<<<<<<<<< changed
            
             'Save the file in the new folder and close it
            On Error Resume Next
            WSNew.Parent.SaveAs foldername & _
            cell.Value & _
            SumOfI & FileExtStr, FileFormatNum
            If Err.Number > 0 Then
                Err.Clear
                ErrNum = ErrNum + 1
                 
                 
                WSNew.Parent.SaveAs foldername & _
                "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
                 
                 
                .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
                "Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
                 
                 
                .Cells(cell.Row, "A").Interior.Color = vbRed
            Else
                .Cells(cell.Row, "B").Formula = _
                "=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
            End If
             
             
            WSNew.Parent.Close False
            On Error GoTo 0
        End If
         
         
         'Show all the data in the range
        My_Range.AutoFilter Field:=FieldNum
         
         
    Next cell
    .Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
    .Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
    .Cells(3, "A").Value = "Unique Values"
    .Cells(3, "B").Value = "Full Path and File name"
    .Cells(3, "A").Font.Bold = True
    .Cells(3, "B").Font.Bold = True
    .Columns("A:B").AutoFit
     
     
End With
 
 
 'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
 
 
If ErrNum > 0 Then
    MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
    & vbNewLine & "There are characters in the name that are not allowed" _
    & vbNewLine & "in a sheet name or the worksheet already exist."
End If
 
 
 'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
     
    For Each ws2 In ActiveWorkbook.Worksheets
        ws2.Protect Password:=yourPassword
    Next ws2
     
End With
 
End Sub

Sub insertrows()
Dim r As Long
Dim r1 As Long
Dim n As Long
r = 2
Application.ScreenUpdating = False
While Cells(r + 1, 1) <> ""
  n = Second(Cells(r + 1, 1) - Cells(r, 1))
  If n > 1 Then
    Rows(r + 1 & ":" & r + n - 1).Insert
    Range("A" & r & ":B" & r + n - 1).FillDown
    For r1 = r + 1 To r + n - 1
      Cells(r1, 1) = Cells(r1 - 1, 1) + 1 / 24 / 3600
    Next
  End If
  r = r + n
Wend
Application.ScreenUpdating = True
End Sub

Sub insertrows()
r = 2
While Cells(r + 1, 1) <> ""
  n = Second(Cells(r + 1, 1)) - Second(Cells(r, 1))
  If n > 1 Then
     Rows(r + 1 & ":" & r + n - 1).Insert
     Range("A" & r & ":B" & r + n - 1).FillDown
     For r1 = r + 1 To r + n - 1
       Cells(r1, 1) = Cells(r1 - 1, 1) + 1 / 24 / 3600
     Next
  End If
  r = r + n
Wend


End Sub

Sub a()
With Sheets(1)
  LR = .Cells(.Rows.Count, "A").End(xlUp).Row
  drow = 2
  For r = 1 To LR
    arr1 = Split(.Cells(r, 1), "/")
    arr2 = Split(.Cells(r, 2) & "/" & .Cells(r, 3), "/")
    arr3 = Split(.Cells(r, 4), ",")
    With Sheets(2)
      For a1 = 0 To 1
        For b1 = 0 To 2
          For d1 = 0 To 2
            .Cells(drow, 1) = arr1(a1)
            .Cells(drow, 2) = arr2(b1)
            .Cells(drow, 3) = arr3(d1)
            drow = drow + 1
          Next
        Next
      Next
    End With
  Next
End With
End Sub