raghuprabhu's Profile
Expert
1651
Points

Questions
16

Answers
25

  • Expert Asked on April 1, 2018 in VBA.

    Hi Narsingh, the lines below are the last 5 lines of the code.

    ElseIf Not Intersect(Target, Range(“C2:D40000”)) Is Nothing Then
    Target.Value = Time
    
    Cancel = True
    
    End If   <<<<insert two lines as shown below
    
    End Sub
    
    ElseIf Not Intersect(Target, Range(“C2:D40000”)) Is Nothing Then
    
    Target.Value = Time
    
    Cancel = True
    
    End If
    Application.Wait Now + TimeValue(“00:00:20”)
    
    ActiveWorkbook.Close Savechanges:=True
    End Sub
    

    hope this helps…

    • 50 views
    • 2 answers
    • 0 votes
  • Expert Asked on April 1, 2018 in Excel: Forumlas.

    Hi Narsing,

     

    Select the cell and copy, then paste special values. The formula will change to value.

     

    Hope this helps.

    • 178 views
    • 2 answers
    • 0 votes
  • Expert Asked on April 1, 2018 in VBA.

    Hi All and Hyside2,

    I have a master file with the following headings

    S No
    Item
    Price
    Qty
    Total
    Distributed
    Task1
    Task2
    Task3
    Task4
    Completed
    Consolidated
    Comments
    Team Member

    The Team leader inputs the data in first 4 columns and selects the name of the team member to be given the task for column 14.

    He then runs the macro ExportByName and new workbooks are created if they already exist then add to the end of the file.

    The team members do the tasks and fill in columns Task1, Task2, Task3, Task4 and then date completed.

    When the team leader runs the following macros

    Sub BringInAllCompletedData()
    Call SortAllFiles
    Call LoopThroughDirectory
    Call UpdateDateInSheet1ColK
    Call UpdateOriginalData
    Call ClearSheet1
    End Sub

    All the work completed is consolidated.

    Sub ExportByName()
    
    Dim unique(1000) As String
    
    Dim wb(1000) As Workbook
    
    Dim ws As Worksheet
    
    Dim x As Long
    
    Dim y As Long
    
    Dim ct As Long
    
    Dim uCol As Long
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Application.Calculation = xlCalculationManual
    
    Application.DisplayAlerts = False
    ‘Your main worksheet info.
    
    Set ws = ActiveWorkbook.Sheets(“OriginalData”)
    Let uCol = 14 ‘Column O
    Dim Strt As Long, Stp As Long: Let Strt = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1: Stp = ws.Cells(ws.Rows.Count, uCol).End
    (xlUp).Row
    Let ws.Range(“F” & Strt & “:F” & Stp & “”).Value = Format(Date, “dd/mmm/yyyy”) ‘ adding the dates to the new rows
    Let ws.Range(“A” & Strt & “:A” & Stp & “”).Value = Application.Evaluate(“=row(” & Strt & “:” & Stp & “)-1”) ‘ adding the S.no. to
    the new rows
    ct = 0
    For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
    
    unique(ct) = ActiveSheet.Cells(x, uCol).Text
    
    ct = ct + 1
    
    End If
    
    Next x
    For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row – 1
    
    If unique(x) “” Then
    
    If Dir(ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, vbNormal) = “” Then ‘If unique file does not exist
    Workbooks.Add: Set wb(x) = ActiveWorkbook
    
    ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
    
    Else
    
    Workbooks.Open filename:=ThisWorkbook.Path & “\” & unique(x) & “.xlsx”
    
    Set wb(x) = ActiveWorkbook
    
    End If
    For y = Strt To Stp
    
    If ws.Cells(y, uCol) = unique(x) Then
    
    ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
    
    wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial
    Paste:=xlPasteValuesAndNumberFormats
    
    End If
    
    Next y
    
    ‘autofit
    
    wb(x).Sheets(1).Columns.AutoFit
    
    wb(x).SaveAs ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
    wb(x).Close SaveChanges:=True
    
    Else
    
    ‘Quit loop
    
    Exit For
    
    End If
    
    Next x
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
    Application.Calculation = xlCalculationAutomatic
    ErrHandler:
    
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
    Application.Calculation = xlCalculationAutomatic
    End Sub
    Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
    
    CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
    
    End Function
    Sub BringInAllCompletedData()
    
    Call SortAllFiles
    
    Call LoopThroughDirectory
    
    Call UpdateDateInSheet1ColK
    
    Call UpdateOriginalData
    
    Call ClearSheet1
    
    End Sub
    ‘https://www.mrexcel.com/forum/excel-questions/471802-vba-open-file-run-code-close-save-open-next-file.html
    
    Sub SortAllFiles()
    
    Dim folderPath As String
    
    Dim filename As String
    
    Dim wb As Workbook
    Application.DisplayAlerts = False
    folderPath = ActiveWorkbook.Path & “\” ‘change to suit
    
    If Right(folderPath, 1) “\” Then folderPath = folderPath + “\”
    
    filename = Dir(folderPath & “*.xlsx”)
    
    Do While filename “”
    
    Application.ScreenUpdating = False
    
    Set wb = Workbooks.Open(folderPath & filename)
    
    ‘Call a subroutine here to operate on the just-opened workbook
    
    If filename = “zmaster.xlsm” Then
    
    Exit Sub
    
    Else
    
    Call SortSheet1InAllFiles
    
    End If
    
    filename = Dir
    
    Loop
    
    Application.ScreenUpdating = True
    
    Application.DisplayAlerts = True
    
    End Sub
    Sub SortSheet1InAllFiles()
    
    Dim MyFile As String
    
    Dim eRow As Long
    
    Dim RowsConsolidated As Long
    
    Dim LastRow As Long
    
    Dim i As Long
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells.Select
    
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
    
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“K2:K” & eRow) _
    
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets(“Sheet1”).Sort
    
    .SetRange Range(“A1:N” & eRow)
    
    .Header = xlYes
    
    .MatchCase = False
    
    .Orientation = xlTopToBottom
    
    .SortMethod = xlPinYin
    
    .Apply
    
    End With
    
    ActiveWorkbook.Save
    
    Range(“A1”).Select
    
    ActiveWorkbook.Close
    End Sub
    ‘http://www.exceltrainingvideos.com/transfer-data-multiple-workbooks-master-workbook-automatically/
    Sub LoopThroughDirectory()
    
    Dim MyFile As String
    
    Dim eRow As Long
    
    Dim LRL As Long
    
    Dim LRK As Long
    
    Dim i As Long
    Dim FilePath As String
    
    FilePath = ActiveWorkbook.Path & “\”
    Application.DisplayAlerts = False
    
    Application.ScreenUpdating = False
    
    Sheets(“Sheet1”).Activate
    
    MyFile = Dir(FilePath)
    
    Do While Len(MyFile) > 0
    
    If MyFile = “zmaster.xlsm” Then
    
    Exit Sub
    
    End If
    Workbooks.Open (FilePath & MyFile)
    
    LRK = Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row ‘Column L
    
    LRL = Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).Row ‘Column K
    For i = LRL To LRK
    
    Range(“A” & LRL & ” : ” & “K” & LRK).Copy
    
    Next
    
    ActiveWorkbook.Close
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    ActiveSheet.Paste Destination:=Worksheets(“Sheet1”).Range(Cells(eRow, 1), Cells(eRow, 11))
    If MyFile = “zmaster.xlsm” Then
    
    Exit Sub
    
    End If
    Workbooks.Open (FilePath & MyFile)
    
    For i = LRL To LRK – 1
    
    If Range(“L” & i).Value = “” Then
    
    Range(“L” & i).Value = Date
    
    Columns(“L:L”).NumberFormat = “[$-C09]dd-mmm-yy;@”
    
    End If
    
    Next
    
    Range(“A1”).Select
    
    ActiveWorkbook.Save
    
    ActiveWorkbook.Close
    MyFile = Dir
    
    ActiveWorkbook.Save
    
    Loop
    Columns(“A:D”).Select
    
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
    
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“A2:A” & eRow) _
    
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets(“Sheet1”).Sort
    
    .SetRange Range(“A1:D” & eRow)
    
    .Header = xlYes
    
    .MatchCase = False
    
    .Orientation = xlTopToBottom
    
    .SortMethod = xlPinYin
    
    .Apply
    
    End With
    Application.ScreenUpdating = True
    
    Application.DisplayAlerts = True
    
    End Sub
    Sub UpdateDateInSheet1ColK()
    
    Dim eRow As Long
    
    Dim i As Long
    Sheets(“Sheet1”).Activate
    
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    For i = 2 To eRow
    
    If Range(“K” & i) “” Then
    
    Range(“L” & i).Value = Format(Date, “dd/mmm/yyyy”)
    
    End If
    
    Next
    
    End Sub
    ‘https://www.youtube.com/watch?v=AzhQ5KiNybk
    
    Sub UpdateOriginalData()
    
    Dim i As Integer
    
    Dim j As Integer
    
    Dim LastRow1 As Integer
    
    Dim LastRow2 As Integer
    
    Dim SNo As Double
    LastRow1 = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
    
    LastRow2 = Sheets(“OriginalData”).Range(“A” & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow1
    
    SNo = Sheets(“Sheet1”).Cells(i, “A”).Value
    
    Sheets(“OriginalData”).Activate
    
    For j = 2 To LastRow2
    
    If Sheets(“OriginalData”).Cells(j, “A”).Value = SNo Then
    
    Sheets(“Sheet1”).Activate
    
    Sheets(“Sheet1”).Range(Cells(i, “G”), Cells(i, “L”)).Copy
    
    Sheets(“OriginalData”).Activate
    
    Sheets(“OriginalData”).Range(Cells(j, “G”), Cells(j, “L”)).Select
    
    ActiveSheet.Paste
    
    End If
    
    Next j
    
    Application.CutCopyMode = False
    
    Next i
    
    Sheets(“OriginalData”).Activate
    
    Cells.Select
    
    ActiveWorkbook.Save
    
    Selection.Columns.AutoFit
    
    Range(“A1”).Select
    End Sub
    Sub ClearSheet1()
    
    Dim eRow As Long
    Sheets(“Sheet1”).Activate
    
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Range(“A2:O” & eRow).Select
    
    Selection.ClearContents
    
    Selection.Columns.AutoFit
    
    Range(“A1”).Select
    
    ActiveWorkbook.Save
    
    End Sub
    
    

    This is a complete project and I use it at work.

    I was able to do this thanks mainly to Hyside2 for his guidance and encouragement.

    Regards

    Raghu Prabhu

    • 56 views
    • 6 answers
    • 0 votes
  • Expert Asked on March 17, 2018 in VBA.

    Hi Hyside2,

     

    Basically edit this for loop.

     

    If unique(x) <> “” Then
    ‘add workbook
    Set wb(x) = Workbooks.Add

    ‘copy header row
    ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

    ‘loop to find matching items in ws and copy over
    For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If ws.Cells(y, uCol) = unique(x) Then
    ‘copy full formula over
    ‘ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)
    ‘to copy and paste values
    ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
    wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)
    End If
    Next y
    ‘autofit
    wb(x).Sheets(1).Columns.AutoFit
    ‘save when done
    wb(x).SaveAs ThisWorkbook.Path & “\” & unique(x)
    wb(x).Close SaveChanges:=True
    Else
    ‘once reaching blank parts of the array, quit loop
    ‘if new lines are in the master workbook, copy and paste them at the bottom of the unique work sheets             <<<<<<   Write this code
    Exit For
    End If

     

    Thanks

    Raghu

    • 56 views
    • 6 answers
    • 0 votes
  • Expert Asked on March 16, 2018 in VBA.

    Hi Hyside2,

    Want to change the code, as follows

     

    If unique file exists open then

    Go back to master, select all records for the unique member

    Copy

    Go back to the unique file

    Go to the last line and paste

    Save and close

    Else

    Create unique fille

    Go back to master, select all records for the unique member

    Copy

    Go back to the unique file

    Go to the last line and paste

    Save and close

    End if

     

    Thank you

     

    Regards

    Raghu

    • 56 views
    • 6 answers
    • 0 votes
  • Expert Asked on March 12, 2018 in VBA.

    Thanks Hyside2, Will try out and get back to you.

     

    Regards

    Raghu

    • 56 views
    • 6 answers
    • 0 votes
  • Expert Asked on February 26, 2018 in VBA.

    Sorted this out.

     

    thanks.

    • 55 views
    • 1 answers
    • 0 votes
  • Expert Asked on February 23, 2018 in VBA: General.

    Thanks Hyside2

    • 43 views
    • 2 answers
    • 0 votes
  • Expert Asked on February 16, 2018 in Excel: Filters & Sorting.

    SORTED!

     

    Private Sub AnotherSheet()
    
    Dim sDate As Date
    
    Dim tDate As Date
    
    Dim PayDay As Date
    
    Dim DueDate As Date
    
    Dim PayCal As String
    
    Dim LastRow As Integer
    
    Dim i As Integer
    Sheets("PayPeriod").Select
    sDate = Range("G2").Value
    
    tDate = Range("G3").Value
    
    PayDay = Range("G4").Value
    
    PayCal = Range("G5").Value
    LastRow = Sheets("Member_List").Range("A" & Rows.Count).End(xlUp).Row
    
    'Sheets("Report").Range("A2:C25").ClearContents
    Sheets("Report").Select
    
    Range("A1").Select
    
    ActiveCell.FormulaR1C1 = "Name"
    
    Range("B1").Select
    
    ActiveCell.FormulaR1C1 = "Due Date"
    
    Range("C1").Select
    
    ActiveCell.FormulaR1C1 = "Amount"
    
    Range("A1:C1").Select
    
    Selection.Font.Bold = True
    
    With Selection
    
    .HorizontalAlignment = xlCenter
    
    .VerticalAlignment = xlBottom
    
    .WrapText = False
    
    .Orientation = 0
    
    .AddIndent = False
    
    .IndentLevel = 0
    
    .ShrinkToFit = False
    
    .ReadingOrder = xlContext
    
    .MergeCells = False
    
    End With
    Sheets("Member_List").Select
    
    Range("A1").Select
    
    ActiveCell.FormulaR1C1 = "Name"
    
    Range("B1").Select
    
    ActiveCell.FormulaR1C1 = "Due Date"
    
    Range("C1").Select
    
    ActiveCell.FormulaR1C1 = "Amount"
    
    Range("A1:C1").Select
    
    Selection.Font.Bold = True
    
    With Selection
    
    .HorizontalAlignment = xlCenter
    
    .VerticalAlignment = xlBottom
    
    .WrapText = False
    
    .Orientation = 0
    
    .AddIndent = False
    
    .IndentLevel = 0
    
    .ShrinkToFit = False
    
    .ReadingOrder = xlContext
    
    .MergeCells = False
    
    End With
    LastRow = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
    For i = 2 To LastRow
    
    DueDate = Cells(i, 2).Value
    
    If (DueDate >= sDate And DueDate <= tDate) And (Cells(i, 4).Value = "No") Then
    
    Sheets("Member_List").Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=Sheets("Report").Range("A" & Rows.Count).End(xlUp).Offset(1)
    
    Application.CutCopyMode = False
    
    Cells(i, 4).Value = "Yes"
    
    Cells(i, 5).Value = PayCal
    
    End If
    
    Next i
    
    End Sub
    
    • 92 views
    • 7 answers
    • 0 votes
  • Expert Asked on February 16, 2018 in Excel: Filters & Sorting.

    Hi All,

    I have data in 4 columns A:D in the worksheet “Member_List”. The following code is copying the required data in columns of P:R

    Hi All,

    I have the following code that copies the required data on the same sheet.

    Sub CreateReport()
    
    Dim sDate As Date
    
    Dim tDate As Date
    
    Dim PayDay As Date
    
    Dim DueDate As Date
    
    Dim PayCal As String
    
    Dim LastRow As Integer
    
    Dim i As Integer
    Sheets("PayPeriod").Select
    sDate = Range("G2").Value
    
    tDate = Range("G3").Value
    
    PayDay = Range("G4").Value
    
    PayCal = Range("G5").Value
    Sheets("Member_List").Select
    
    Range("P1").Select
    
    ActiveCell.FormulaR1C1 = "Name"
    
    Range("Q1").Select
    
    ActiveCell.FormulaR1C1 = "Due Date"
    
    Range("R1").Select
    
    ActiveCell.FormulaR1C1 = "Amount"
    
    Range("P1:R1").Select
    
    Selection.Font.Bold = True
    
    With Selection
    
    .HorizontalAlignment = xlCenter
    
    .VerticalAlignment = xlBottom
    
    .WrapText = False
    
    .Orientation = 0
    
    .AddIndent = False
    
    .IndentLevel = 0
    
    .ShrinkToFit = False
    
    .ReadingOrder = xlContext
    
    .MergeCells = False
    
    End With
    LastRow = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
    For i = 2 To LastRow
    
    DueDate = Cells(i, 2).Value
    
    If (DueDate >= sDate And DueDate <= tDate) And (Cells(i, 4).Value = "No") Then
    
    Range(Cells(i, 1), Cells(i, 3)).Copy
    
    Range("P100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    
    Application.CutCopyMode = False
    
    Cells(i, 4).Value = "Yes"
    
    End If
    
    Next i
    End Sub
    

    I want to alter this code to copy it the required data to another worksheet named “Report”

    Regards

    Raghu

    • 92 views
    • 7 answers
    • 0 votes
  • Expert Asked on February 2, 2018 in Excel: Filters & Sorting.

    Thanks Hyside2. I will consider this closed.

    • 92 views
    • 7 answers
    • 0 votes
  • Expert Asked on February 1, 2018 in Excel: Filters & Sorting.

    Brilliant…Hyside2

     

    Thank you very much! Works wonderfully!

     

    • 92 views
    • 7 answers
    • 0 votes