Posts by acw

Sub aaa()
'dimension 2 variables as worksheets, then set to the relevant sheets
  Dim SrcSH As Worksheet
  Dim DataSH As Worksheet
  Set SrcSH = Sheets("Sheet1")
  Set DataSH = Sheets("PBIC 8")
'create an array of the 2 headings to be checked on the source sheet
  headarr = Array("REGISTRATIONNBR", "SERIALNBR")
     
'cycle through the 2 heading items
  For i = LBound(headarr) To UBound(headarr)
'work out which column has the heading
    coll = WorksheetFunction.Match(headarr(i), SrcSH.Rows("1:1"), 0)
'make a range of the relevant data in that column
    Set rng = SrcSH.Range(Cells(2, coll), Cells(Rows.Count, coll).End(xlUp))
'loop through the cells in the range
      For Each ce In rng
'if the cell has something in it then process
        If Not ce = "" Then
'use find to set a variable with the result
          Set findit = DataSH.Cells.Find(what:=ce.Value)
        'something is found
          If Not findit Is Nothing Then
        'make a note of the address for the first found entry
            firstAdd = findit.Address
        'color the items found, then redo the find.  Keep going until you come back
        'to the first address.  Covers multiple appearances of an item.
            Do
              findit.Interior.ColorIndex = 3
              ce.Interior.ColorIndex = 3
              Set findit = DataSH.Cells.Find(what:=ce.Value, after:=findit)
            Loop Until findit.Address = firstAdd
                     
          End If
        End If
      Next ce
    Next i
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set rng = Range("C12:C15")
  strr = ""
  If Not Intersect(Target, rng) Is Nothing And Not IsEmpty(Target.Offset(0, -1)) Then
    Target.Validation.Delete
    For Each ce In Range(Cells(2, Target.Column - 1), Cells(7, Target.Column - 1))
      If ce.Value = Target.Offset(0, -1) Then strr = strr & ce.Offset(0, -1).Value & ","
      
    Next ce
    Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Left(strr, Len(strr) - 1)
    
  End If
End Sub

Sub bbb()
  ChDrive "c"
  ChDir "c:\temp"
  Set fs = CreateObject("Scripting.filesystemobject")
  timee = 2400
  Dim fname As String
  Do
    fname = Format(Now(), "ddmmyy") & timee & ".txt"
    timee = timee - 100
  Loop Until fs.fileexists(fname)
  MsgBox fname
End Sub

Sub MergeSheets()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("All Data - End Result")
  OutSH.Cells.ClearContents
  
  With Sheets("Identified")
    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("A6:H" & lastrow).Copy Destination:=OutSH.Range("A6")
  End With
  
  With OutSH
    .Columns("G").EntireColumn.Delete
    .Columns("F").EntireColumn.Delete
    .Columns("D").EntireColumn.Delete
  End With
  
  With Sheets("unidentified")
    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    .Range("A7:C" & lastrow).Copy Destination:=OutSH.Cells(outrow, 1)
    .Range("E7:E" & lastrow).Copy Destination:=OutSH.Cells(outrow, 4)
    .Range("F7:F" & lastrow).Copy Destination:=OutSH.Cells(outrow, 5)
  End With
  
  OutSH.Columns("A:E").AutoFit
  
End Sub

Sub ccc()
  Dim HorRng As Range, VertRng As Range
  Dim OutSH As Worksheet
  Dim HorRngRows As Integer, HorRngCols As Integer, VertRngRows As Integer, VertRngCols As Integer
  Dim OutRow As Integer
  
  Set HorRng = Application.InputBox("What is the first range", Type:=8)
  Set VertRng = Application.InputBox("What is the second range", Type:=8)
  Set OutSH = Sheets("Sheet2")
  
  HorRngCols = HorRng.Columns.Count
  HorRngRows = HorRng.Rows.Count
  
  VertRngRows = VertRng.Rows.Count
  VertRngCols = VertRng.Columns.Count
  OutSH.Cells.ClearContents
  OutSH.Range("A1").Resize(1, HorRngCols).Value = HorRng.Resize(1, HorRngCols).Value
  
  For i = 2 To HorRngRows
    For j = 1 To VertRngCols
      OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      OutSH.Cells(OutRow, 1).Resize(1, HorRngCols).Value = HorRng.Cells(i, 1).Resize(1, HorRngCols).Value
      OutSH.Cells(OutRow, 1).Offset(0, HorRngCols).Value = VertRng.Cells(1, j).Value
      OutSH.Cells(OutRow, 1).Offset(0, HorRngCols + 1).Value = VertRng.Cells(i, j).Value
    Next j
  Next i
      
  
End Sub

Private Sub cmdAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("PartsData")


'find  first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
  .End(xlUp).Offset(1, 0).Row


'check for a part number
If Trim(Me.txtPart.Value) = "" Then
  Me.txtPart.SetFocus
  MsgBox "Please enter the Code"
  Exit Sub
End If


If WorksheetFunction.CountIf(ws.Range("A:A"), txtPart.Value) = 0 Then


'copy the data to the database
  ws.Cells(iRow, 1).Value = Me.txtPart.Value
  ws.Cells(iRow, 2).Value = Me.txtLoc.Value
  ws.Cells(iRow, 3).Value = Me.txtDate.Value
  ws.Cells(iRow, 4).Value = Me.txtQty.Value


'clear the data
  Me.txtPart.Value = ""
  Me.txtLoc.Value = ""
  Me.txtDate.Value = ""
  Me.txtQty.Value = ""
  Me.txtPart.SetFocus
Else
  MsgBox "This code already exists in the database."
End If


End Sub