Vba code help

Hi, I’ve been tasked with creating a parts spreadsheet in work, so for the past six weeks I have itemised over 2000 parts. After completing the data input I’ve set about making it more user friendly, but have been beaten by my limits on vba. I have manage to 3 vba codes to preform different tasks across 4 mains worksheets (parts list, re-order report, parts movement, catalogue). I’ve made over 4000 function buttons to preform 2 different tasks. 2000 increase parts list cells (Q1:Q2000) by +1 if. clicked. The other 2000 buttons decrease the same cells by -1 if clicked. My third code is also a button which runs a re order report by searching for the word YES in cells (R1:R2000) then copying the rows and populating them into the reorder sheet. But while running my spreadsheet within my maintenance team I encountered a problem, I have no record of parts movement. For the past week I’ve tried and tried and searched the internet but have came up short, in my search a and code building. I need a code to Automatically (no buttons) read cells(Q1:Q2000) for any change (these cells are increased and decreased by 1 with each click of the 2000 add buttons and 2000 remove buttons. The code then needs to copy each row in which the Q cell has increased or decreased (cells A to L) and paste them into parts movement sheet starting in row 5 and pasting into cells ( A to L) . The code also needs to allow the pasted rows to stay and to just create another row if the same part has been increased or decreased. I also need the pasted rows in parts movement sheet to be Timestamped this would allow a history for both used and restocked parts.

developer

Formulas and Functions

Macros and VBA

JMB17

Aug 19, 2020

StevieGis01

Cleaning up the code is often a matter of removing "select" and "activate" and joining whatever was selected/activated with the action. Instead of

Range("A1").Select

Selection.Value = 10

it can be shortened to just

Range("A1").Value = 10

Just my two cents, but since these two procedures have a lot of overlap, you could set up a third procedure to do the work and just pass it the value by which to increase/decrease the cell. And, if you had cells other than F8 that this process worked on, you could pass it the applicable cell(s) on the Parts List worksheet.

Or, you could have the user select the cells they want to increment/decrement and have the macro work on whatever range the user has selected?

Public Sub MinusOnePartClickButtonTest()
     ChangePartCount -1
End Sub

Public Sub AddOnePartClickButtonTest()
     ChangePartCount 1
End Sub

Public Sub ChangePartCount(changeValue As Integer)
     Dim destWkSht As Worksheet
     Dim destCell As Range
     Dim timeStampCell As Range
     
     
     On Error GoTo ErrHandler
     
     
     If changeValue < 0 Then
          Set destWkSht = Sheets("Parts Removed")
     ElseIf changeValue > 0 Then
          Set destWkSht = Sheets("Parts Added")
     Else
          Exit Sub
     End If
     
     
     With destWkSht
          Set destCell = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
          Set timeStampCell = Intersect(.Range("O:O").EntireColumn, destCell.EntireRow)
     End With


     With ThisWorkbook.Worksheets("Parts List")
          .Unprotect ("Password") ' Unlock Sheet
          .Range("F8").Value = .Range("F8").Value + changeValue
          .Range("A8,F8").Copy destCell
          .Protect ("Password") ' Lock Sheet
     End With
     
     timeStampCell.Value = Now
     
     Application.CutCopyMode = False


ExitProc:
     Set destCell = Nothing
     Set destWkSht = Nothing
     Exit Sub
     
ErrHandler:
     MsgBox "Error " & Err.Number & ": " & Err.Description
     Resume ExitProc
     
End Sub

Riny_van_Eekelen
Platinum Contributor
Aug 18, 2020
StevieGis01 My first thought is that a spreadsheet with 4000 (!) buttons is overwhelming. Especially when you are talking about "only" 2000 parts to track. There must be a simpler way, although I do not know how you have structured your data or what exactly you are asked to deliver.

I would probable start having a parts table and a transactions table and link them together using one of Excel's LOOKUP functions, Pivot Tables and/or Power Query / Power Pivot, and do the reporting (plus and minus and history) from there. But again, I have no idea about your real life situation. So, perhaps my thoughts are completely out of line.
- StevieGis01
  Copper Contributor
  Aug 19, 2020
  Hi
  Riny_van_Eekelen Thankyou for your replay, I forgot to mention that im not very good with computers I'm just an electrician. What you said made me rethink my parts. I've now drastically reduced my parts list down to a maximum of 200 across 12 different spreadsheets (1 for each of our machines).
  All my machine spreadsheets are set out the same way, as follows
  1. Parts List (Sheet1)
  2. Reorder Parts Report (Sheet2)
  3. Parts Removed (Sheet3)
  4. Parts Added(Sheet4)
  The parts list (Sheet1) has a max of 200 rows, each row uses cells (A:S),
  On sheet1 I've made a vba button to run a reorder parts report. When clicked the code unlocks sheet1, clears all cells in sheet2, looks for "YES" within cells (R:R200), it then copies the rows cells(A:L,Q,R,S) from sheet1, pastes the rows onto the parts reorder report sheet (Sheet2), then locks sheet1 again.
  
  Within all sheet1 cells (o) I've made a vba button to unlock sheet1, then reduce the value in cell (Q) by 1, then copy cells (A:L,Q,R,S) of the same row and paste them into Sheet3 in the next available row, then return back to sheet1 cell (A) of the same row which had been reduced, and lock sheet1 again.
  
  Within all sheet1 cells (p) I've made a vba button to unlock sheet1, then increase the value in cell (Q) by 1, then copy cells (A:L,Q,R,S) of the same row and paste them into Sheet4 in the next available row, then return back to sheet1 cell (A) of the same row which had been reduced, and lock sheet1 again.
  
  If Possible could you help me with tidying up my already made vba and give and also help me to create a time stamp in cell(o) for both sheet3 and sheet4 for each row that pastes to give me some sort of parts tracking.
  
  My vba codes are
  
  Public Sub RunReOrderReport()
  '
  '       Clear Re Order Sheet First
  '       Run Re Order Count
  '       Based On Re Order Colum "YES" OR " NO"
  '       Copy Row and Paste on to Re order Sheet
  '       Continue Though Sheet Until Complete
  '       End
  '
      ThisWorkbook.Worksheets("Parts List").Unprotect ("Password") ' Unlock Sheet
      Sheets("Re Order Parts Report").Cells.Clear 'Clear Re Order Sheet
      Dim c As Range
      Dim j As Integer
      Dim Source As Worksheet
      Dim Target As Worksheet
  '
  '       Source "Parts List" ("Sheet1")
  '       Target "Re Order Parts Report" ("Sheet2")
  '
      j = 2   'Start Copying To Row 2 In Target Sheet
                  Set Target = ThisWorkbook.Worksheets("Re Order Parts Report")
  '       For Each c In
                  Set Source = ThisWorkbook.Worksheets("Parts List")
          For Each c In Source.Range("G1:G1000")
  '        Do 1000 Rows
              If c = "YES" Then
  '        ("Shee1"),Range.Value = "YES" = TRUE
                 ' Source , ThisWorkbook.Worksheets("Sheet1").Rows.c, Copy.Row = 2, Copy.Target.Rows(j)
                    Source.Rows(c.Row).Copy Target.Rows(j)
                  j = j + 1
              End If
          Next c
      ThisWorkbook.Worksheets("Parts List").Protect ("Password")
  End Sub
  
  Public Sub MinusOnePartClickButtonTest()
  '
  ' PartsRemoved Macro
  ' if -1 button clicked copy stock and row to parts removed sheet
  '
  ThisWorkbook.Worksheets("Parts List").Unprotect ("Password") ' Unlock Sheet
  Sheets("Parts List").Select
  Range("F8").Value = Range("F8").Value - 1
  Range("A8,F8").Select
  Range("F8").Activate
  Selection.Copy
  Sheets("Parts Removed").Select
  Range("A" & Rows.Count).End(xlUp).Offset(1).Select
  ActiveSheet.Paste
  ActiveSheet.Paste
  Sheets("Parts List").Select
  Range("A8").Select
  Application.CutCopyMode = False
  Range("A8").Select
  ThisWorkbook.Worksheets("Parts List").Protect ("Password") ' Lock Sheet
  End Sub
  
  Public Sub AddOnePartClickButtonTest()
  '
  ' PartsRemoved Macro
  ' if -1 button clicked copy stock and row to parts removed sheet
  '
  ThisWorkbook.Worksheets("Parts List").Unprotect ("Password") ' Unlock Sheet
  Sheets("Parts List").Select
  Range("F8").Value = Range("F8").Value + 1
  Range("A8,F8").Select
  Range("F8").Activate
  Selection.Copy
  Sheets("Parts Added").Select
  Range("A" & Rows.Count).End(xlUp).Offset(1).Select
  ActiveSheet.Paste
  ActiveSheet.Paste
  Sheets("Parts List").Select
  Range("A8").Select
  Application.CutCopyMode = False
  Range("A8").Select
  ThisWorkbook.Worksheets("Parts List").Protect ("Password")
  End Sub
  
  I Hope this makes sense as I couldn't figure out how to make my vba look the same as everybody else's post's on here
  
  Thanks again
  - JMB17
    Bronze Contributor
    Aug 19, 2020
    StevieGis01
    
    Cleaning up the code is often a matter of removing "select" and "activate" and joining whatever was selected/activated with the action. Instead of
    
    Range("A1").Select
    Selection.Value = 10
    
    it can be shortened to just
    Range("A1").Value = 10
    
    Just my two cents, but since these two procedures have a lot of overlap, you could set up a third procedure to do the work and just pass it the value by which to increase/decrease the cell. And, if you had cells other than F8 that this process worked on, you could pass it the applicable cell(s) on the Parts List worksheet.
    
    Or, you could have the user select the cells they want to increment/decrement and have the macro work on whatever range the user has selected?
    
    Public Sub MinusOnePartClickButtonTest() ChangePartCount -1 End Sub Public Sub AddOnePartClickButtonTest() ChangePartCount 1 End Sub Public Sub ChangePartCount(changeValue As Integer) Dim destWkSht As Worksheet Dim destCell As Range Dim timeStampCell As Range On Error GoTo ErrHandler If changeValue < 0 Then Set destWkSht = Sheets("Parts Removed") ElseIf changeValue > 0 Then Set destWkSht = Sheets("Parts Added") Else Exit Sub End If With destWkSht Set destCell = .Range("A" & .Rows.Count).End(xlUp).Offset(1) Set timeStampCell = Intersect(.Range("O:O").EntireColumn, destCell.EntireRow) End With With ThisWorkbook.Worksheets("Parts List") .Unprotect ("Password") ' Unlock Sheet .Range("F8").Value = .Range("F8").Value + changeValue .Range("A8,F8").Copy destCell .Protect ("Password") ' Lock Sheet End With timeStampCell.Value = Now Application.CutCopyMode = False ExitProc: Set destCell = Nothing Set destWkSht = Nothing Exit Sub ErrHandler: MsgBox "Error " & Err.Number & ": " & Err.Description Resume ExitProc End Sub

Forum Discussion

Vba code help

Share

Resources