Posts by B Rama Krishna

Sub CellToComment()

Dim xc As Long

Dim ws As Worksheet

Set ws = ActiveSheet

Dim xr As Integer

Dim CheckRange As Range



Set ws = ActiveWorkbook.Sheets("Sheet1")



With ws

For xr = 9 To 1200

Set CheckRange = Sheets("Bill").Range("W9:Y1200")

If CheckRange Is Nothing Then

.Cells(xr, 9).ClearComments



Else

.Cells(xr, 9).ClearComments

.Cells(xr, 9).AddComment .Cells(xr, 23).Value & " Product ID:, " & .Cells(xr, 24).Value & " Product Amount:, " & .Cells(xr, 25).Value & " Product Paid Amount:. "



End If

Next



End With



End Sub

Sub GetInfoFromSheet()


Dim ws As Worksheet
Dim iCounter As Integer
Dim lngRows As Long

ThisWorkbook.Worksheets("Extract").Range("B10").CurrentRegion.ClearContents
ThisWorkbook.Worksheets("Extract").[B10] = "Worksheet Name"

ThisWorkbook.Worksheets("Extract").[C10] = "No of Records"

iCounter = 11

For Each ws In ThisWorkbook.Worksheets

If Not ws.Name = "Extract" And Worksheets("Extract").Range("C2") <> "" Then

 ws.Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=Worksheets("Extract").Range("C2"), VisibleDropDown:=False

 ThisWorkbook.Worksheets("Extract").Range("C" & iCounter) = ws.Cells.SpecialCells(xlCellTypeVisible).Rows.Count
 ThisWorkbook.Worksheets("Extract").Range("B" & iCounter) = ws.Name

 iCounter = iCounter + 1

End If

Next ws

End Sub


Sub ClearAllFilters()


Dim wk As Worksheet

For Each wk In ThisWorkbook.Worksheets

If Not wk.Name = "Extract" Then

  wk.Range("A1").CurrentRegion.AutoFilter Field:=3

End If

Next wk

ThisWorkbook.Worksheets("Extract").Range("B10").CurrentRegion.ClearContents

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)


If Worksheets("Sheet_name").Range("A1") <> '"  then   'change the sheet name suitably
       
       For Each cell In Worksheets("Sheet_name").Range("E1:E2000")   'change the sheet name suitably
           
             If cell.Value = "" Then
                 
                  If cell.offset(0,-4).value <> "" then


                        MsgBox "Response required", vbInformation, "selection not made"
                       cell.Select
                       Cancel = True
                       Exit Sub


                  End if


            End If
 
       Next


End if


End Sub

Sub SplitCells()


Dim rng As Range, ws As Worksheet, rngData As Range
Dim WorkRng As Range
Dim lLfs As Long, lRows As Long, lCols As Long
Dim i As Long, j As Long, lstRow As Long
Dim blnTmp As Boolean, blnFinalData As Boolean, blnNextRow As Boolean
Dim iLast As Long


On Error GoTo ErrorHandler:


Application.ScreenUpdating = False


For Each ws In ActiveWorkbook.Worksheets


  If ws.Name = "tmp" Then blnTmp = True
  
  If ws.Name = "FinalData" Then blnFinalData = True
  
Next ws


If Not blnTmp Then ActiveWorkbook.Worksheets.Add.Name = "tmp"


If Not blnFinalData Then ActiveWorkbook.Worksheets.Add.Name = "FinalData"


Set ws = ActiveWorkbook.Worksheets("Sample")


lRows = ws.UsedRange.Rows.Count
lCols = ws.UsedRange.Columns.Count


'clear the data in sht "FinalData" and add col headers


Worksheets("FinalData").Cells.Clear


For j = 1 To lCols
  Worksheets("FinalData").Cells(1, j) = "Col" & j
Next j


lstRow = 2 'the row to be used for copying data on Finaldata sheet


With ws.UsedRange


For i = 1 To lRows


    For j = 1 To lCols
        
        Worksheets("tmp").UsedRange.Clear
        
        .Cells(i, j).Copy Destination:=Worksheets("tmp").Range("A1")
        
        
        Set rng = Worksheets("tmp").Range("A1")
        lLfs = VBA.Len(rng) - VBA.Len(VBA.Replace(rng, vbLf, ""))
        
        If lLfs > 0 Then
        
            rng.Offset(1, 0).Resize(lLfs).Insert shift:=xlShiftDown
            rng.Resize(lLfs + 1).Value = Application.WorksheetFunction.Transpose(VBA.Split(rng, vbLf))


            
            rng.CurrentRegion.Copy Destination:=Worksheets("FinalData").Cells(lstRow, j)


     
        Else
        
            Worksheets("FinalData").Cells(lstRow, j).Value = .Cells(i, j).Value
        
     
        End If
      
      
    Next j
    
     lstRow = Worksheets("FinalData").UsedRange.Find("*", LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Offset(1, 0).Row
    
Next i


End With




 Dim cl As Range
 
 Set ws = ActiveWorkbook.Worksheets("FinalData")
 
 Set rng = ws.UsedRange.SpecialCells(xlCellTypeBlanks)
 
 For Each cl In rng
 
    cl.Offset(-1, 0).Copy cl
 
 
 Next cl
 
 ws.Rows(1).Delete
 
 ws.Columns.AutoFit
 
 MsgBox "Unmerging of Data Complete!", vbInformation + vbOKOnly, "Task completed ..."
 
 Exit Sub
 
ErrorHandler:
 
 MsgBox "Err No" & Err.no & vbCrLf & _
        "Err Description:" & Err.Description, vbCritical + vbOKOnly, "Error ..."
        
 Application.ScreenUpdating = True
 


End Sub

Sub Worksheet_Change(ByVal Target As Range)


Dim rng As Range, Cell As Range, strFormat As String
Dim i As Integer


On Error GoTo ErrorHandler:


If Not Intersect(Target, Range("A2:D10")) Is Nothing And Target.Value <> "" Then   'change the range as required


    Application.EnableEvents = False
    
    For Each Cell In Target
    
        With Cell
           
           strFormat = "@@@@" & String(Len(.Value) - 2, "@")
           
           .Value = UCase(Format(.Value, strFormat))
            
            
            i = WorksheetFunction.RandBetween(2, Len(.Value) - 1)
            
            .Value = Left(.Value, i) & "-" & Right(.Value, Len(.Value) - i)
            
            
        End With
    
     
    Next Cell
   
    Application.EnableEvents = True


End If


Exit Sub


ErrorHandler:


MsgBox "Error Number:" & Err.Number & vbCrLf & _
       "Error Description:" & Err.Description & vbCrLf & _
       "Error at: " & Cell.Address
       
Application.EnableEvents = True


End Sub