How do I populate a list on sheet1 from data in various places on different sheets

tossit2 · Jun 7, 2016

I want data from cells under column E, in sheet 2, 3 & 4 …to automatically copy over to Column AG, sheet 1… progressively filling in the next blank cell in column AG on sheet 1…...but I only want it to copy over data from sheets 2, 3 and 4 if there is an "x" in the adjacent cell to the left of the data on sheets 2, 3 or 4.
What I am working on is a complex Task Tracker in excel. I want the various tasks throughout the book to move to a list on a "Priority Sheet" IF I place an "X" in the box directly to the left of them (in whatever sheet they are currently in).
[FONT=&quot]I am very new to all this but really trying to self-educate. I am trying really hard to ask the question correctly. Please be gentle. I will get better. Excel 2016[/FONT]

L. Howard · Jun 22, 2016

Here is another modified version of the workbook.

Should down load to the Project Priorities Sheet, there you can double-click one of the tasks under GO & DO header, should return you to the GO & DO project sheet. Depending on where on the sheet the cell is that you were returned to, there is code that will center that cell on the screen, making it more viewable and workable on the screen.

https://www.dropbox.com/s/nrgle07xw9q3aiw/Community Projects Macro EXP_DB.xlsm?dl=0

On the project sheets, I modified the macros to run each by themselves and each have three options on how to run them.

First is the project sheets column D event macro, activated by an X or x entered in column D next to a task.

The To_Completed_Sheet_As_Archive, Delete_Task_Proj_Prior and ReInstall_Task can be run by either:

The blue button next to the name, by the key strokes an shown in the cell comment or from the Quick Access Toolbar via the last three icons.
The icons are a double-pointed arrow pointing to the right, a white X in red circle, a double-pointed arrow to the left. Hover the cursor over the icon for macro name.

You can play with those options and decide which suits you best. And what changes you may need on the workbook in general.

Not much knowledge of goats. I am in Oregon.

Howard

Here are the macros and their placement.

In the Project Priorities Sheet module.

Code:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target = "" Then
  MsgBox "Empty Cell"
  Cancel = True
  Exit Sub
End If

Dim wb As Workbook
Dim ws As Worksheet
Dim wsNme As String
Dim colNum As Long

Set wb = ActiveWorkbook
colNum = ActiveCell.Column
wsNme = Cells(1, colNum)

If WorksheetExists(wsNme) = True Then GO_BACK_To_Project_Sheet
Cancel = True
End Sub

In the ThisWorkbook module

Code:

Option Explicit
Option Compare Text

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

'// Current code in use

Dim rngD As Range
Dim tskCel As Range
Dim tskCol As Long
Dim tskMgr As String
Dim pjSht As String

    Set rngD = Target.Parent.Range("D:D")
       
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, rngD) Is Nothing Then Exit Sub
    If Target.Worksheet.Name = "Project Priorities" Then Exit Sub
    
    
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 
 
    If Target.Offset(, 2) <> "" Then
      MsgBox "Transfered on " & Target.Offset(, 2).Value
      Target.Select
      GoTo noTsk
    End If
  
    If Target.Offset(, 1) = "" Then
      Target = ""
      MsgBox "No Task in " & Target.Offset(, 1).Address
      Target.Select
      GoTo noTsk
    End If
     
    
pjSht = Target.Worksheet.Name
tskCol = Sheets("Project Priorities").UsedRange.Find(pjSht, LookIn:=xlValues, _
    LookAt:=xlWhole).Column
    
Set tskCel = Sheets("Project Priorities").Cells(Rows.Count, tskCol).End(xlUp)(2)
 
    With Target
      If .Value = "x" Then
      .Offset(, 2) = Date
      tskCel = .Offset(, 1) '& ":" & vbLf & "  " & Target.Offset(, 1)
      tskCel.Offset(, -1) = .Offset(, 2)
      tskCel.Offset(, -2) = .Offset(, 3)
      End If
    End With
    
noTsk:
 Application.EnableEvents = True
 Application.ScreenUpdating = True
            
End Sub

In Standard Module1

Code:

Option Explicit

Sub To_Completed_Sheet_As_Archive()
'// Ctrl + Shift + T
'// For use on all project sheets.
'// Run from the sheet of choice

Dim pjSht As String
Dim tskCol As Long, blnkRow As Long, blnkCol As Long
Dim tskCel As Range, c As Range, rngDel As Range
Dim FindString As String
Dim TheTaskRng As Range ' input box selections
Dim y As Range

 On Error GoTo NotValidInput
 
  Set TheTaskRng = Application.InputBox( _
    Prompt:="Select COMPLETED Task/s in Column E " & vbCr & _
            "For transfer to ""Completed Tasks"" sheet.", Type:=8)
    
    If Not TheTaskRng.Column = 5 Then
      MsgBox "Column E cell selection only"
      Exit Sub
    End If
    
     If TheTaskRng.Offset(, -1) = "" Then
      MsgBox "No ""X"" in column ""E""" & vbCr & _
             "The selected TASK has not been" & vbCr & _
             "transfered to Priority sheet"
      Exit Sub
    End If

Application.ScreenUpdating = False

pjSht = ActiveSheet.Name


tskCol = Sheets("Completed Tasks").UsedRange.Find(pjSht, LookIn:=xlValues, _
               LookAt:=xlWhole).Column
   
Set tskCel = Sheets("Completed Tasks").Cells(Rows.Count, tskCol).End(xlUp)(2)

For Each c In TheTaskRng

  
     Set tskCel = Sheets("Completed Tasks").Cells(Rows.Count, tskCol).End(xlUp)(2)
     Set rngDel = Application.Union(c.Offset(, -1), c.Offset(, 1), c.Offset(, 2), c.Offset(, 3))

     With c
       .Resize(1, 3).Copy tskCel
        rngDel.ClearContents
        .Offset(, 3) = "AC - "
        .Offset(, 3).Font.Size = 8
       .Font.Italic = True
       .Font.Bold = True
       .Font.Size = 8
       .Offset(, 3).Select
     End With

Next


Application.ScreenUpdating = True

NotValidInput:
End Sub


Sub Delete_Task_Proj_Prior()
'// Ctrl + Shift + D
'// For use on all project sheets.
'// Run from the sheet of choice
'/ by Claus
Dim TheTaskRng As Range ' input box selections

Dim aTsk As Range, aTskDel As Range, rngBig As Range


On Error GoTo NotValidInput
  
Set TheTaskRng = Application.InputBox( _
    Prompt:="Select small print Italic COMPLETED Task/s in Column E" & vbCr & _
    "For removal from ""Project Priorities"" sheet", Type:=8)
    
If Not TheTaskRng.Column = 5 Then
    MsgBox "Column E cell selection only"
    Exit Sub
End If
    
Application.ScreenUpdating = False
    

With Sheets("Project Priorities")


    For Each aTsk In TheTaskRng

        Set aTskDel = .Cells.Find(What:=aTsk, LookIn:=xlValues, LookAt:=xlPart)
        
         If InStr(aTsk.Offset(, 3), "PP Del") > 0 Then
            MsgBox "     The Status column shows the selected Task" & vbCr & _
                   "       has already been deleted from the sheet" & vbCr & vbCr & _
                   "                       ""Project Priorities"" "
            Exit Sub
         End If
        

        If Not aTskDel Is Nothing Then

            aTsk.Offset(, 3) = aTsk.Offset(, 3) & "PP Del"

            If rngBig Is Nothing Then
                Set rngBig = aTskDel.Offset(, -2).Resize(1, 3)
            Else
                Set rngBig = Union(rngBig, aTskDel.Offset(, -2).Resize(1, 3))
            End If
        End If
    Next 'aTsk
    rngBig.Delete shift:=xlUp
End With


NotValidInput:
Application.ScreenUpdating = True
End Sub


Sub ReInstall_Task()
'// Ctrl + Shift + R
'// For use on all project sheets.
'// Run from the sheet of choice

Dim reTask As Range, tskScan As Range
Dim prjSht As String, tskMgr As String
Dim aNameCheck As Range
Dim response As Variant

 On Error GoTo NotValidInput
   Set reTask = Application.InputBox("Select small bold print Italic Task/s in Column E" & vbCr & _
                                     "To re-install an archived Task/s", "Install Retired Task", , , , , , 8)
  
    If Not reTask.Font.Italic = True Then
      MsgBox "Task names in Bold Italic only are archived, review your selection"
      Exit Sub
    End If
    
    If Not reTask.Column = 5 Then
      MsgBox "Column E cell selection only"
      Exit Sub
    End If

prjSht = ActiveSheet.Name

'MsgBox prjSht
'MsgBox reTask

With Sheets("Completed Tasks")

    Set tskScan = Sheets("Completed Tasks").Cells.Find(What:=reTask, _
                     LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                     SearchDirection:=xlNext, MatchCase:=False)

    reTask.Offset(, 2).Clear

    'input box that can accept both text and numbers
    response = Application.InputBox("Enter a manager name.", "Re-Task Manager Name", , , , , , 1 + 2)

    With reTask
      .Offset(, 2) = response
      .Offset(, 3) = "Re-Install" & " " & Date
      .Offset(, 3).Font.Size = 8
      .Font.Italic = False
      .Font.Bold = False
      .Font.Size = 11
    End With
 End With

NotValidInput:
End Sub

'// This macro is called (run) by the Project Priorities Double_Click
'// event macro which is in the Project Priorities sheet's module.
Sub GO_BACK_To_Project_Sheet()

Dim shtNme As String
Dim pcolumn As Long
Dim FindTask As String
Dim rng As Range
    
Dim VisRows As Long
Dim VisCols As Long
    
    
pcolumn = ActiveCell.Column
FindTask = ActiveCell.Value
shtNme = Cells(1, pcolumn)


Application.ScreenUpdating = False

        With Sheets(shtNme).UsedRange
            Set rng = .Find(What:=FindTask, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Application.Goto rng ', True
     
            Else
                MsgBox "Nothing found"
                Exit Sub
            End If
        End With
  
'// The code from here down centers the FindTask cell in the screen.
'// If the FindTask cell is near the sheet border it may appear there
'// was NO centering.  Without the centering, the cell would always
'// be in the top left of the screen, requiring you to scroll up and left
'// to put the cell in a more viewable and workable position on the screen.

rng.Parent.Parent.Activate
rng.Parent.Activate

With ActiveWindow.VisibleRange
    VisRows = .Rows.Count
    VisCols = .Columns.Count
End With

Application.Goto rng, Scroll:=True

With Application
    .Goto reference:=rng.Parent.Cells( _
        .WorksheetFunction.Max(1, rng.Row + _
        (rng.Rows.Count / 2) - (VisRows / 2)), _
        .WorksheetFunction.Max(1, rng.Column + _
        (rng.Columns.Count / 2) - _
        .WorksheetFunction.RoundDown((VisCols / 2), 0))), _
         Scroll:=True
End With

rng.Select
Application.ScreenUpdating = True

End Sub


'// This function returns TRUE if the sheet name exists.
'// See last line of code in the Double-Click macro in Project Priorities module.

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

tossit2 · Jun 24, 2016

Hey Howard,
I am working on running thru the inner workings of the whole tracker. I can't locate the icons in the Quick Access Toolbar though.

L. Howard · Jun 24, 2016

Okay, not sure what you get when you download the link.
My Quick Access Toolbar is located below the main Ribbon, and above the Name Box, Formula Bar and the fx (Insert Function) row of items.

It may be that you will need to install the icons on your version of Excel on your computer for them to be visible. I say this because when I open a new worksheet, those same icons are visible in the Quick Access, but have no macro or function connected to them.

When I download from the link back to me, they are there and functional. If you decide that is where you want to run the macros from, then it is fairly easy to install them on your machine/workbook version.

And with the projects sheets, those can be 'cleaned' of all the stuff you really don't need for your working version of the workbook.

Howard

L. Howard · Jun 24, 2016

L. Howard said:
I say this because when I open a new worksheet, those same icons are visible in the Quick Access, but have no macro or function connected to them.

A correction on the above.

The icons do evoke the InputBox associated with the macro icon clicked. However, it is playing to an unworkable sheet and workbook. As I said, I never used these to any extent and may not be providing good input here.

Howard

L. Howard · Jun 30, 2016

I presume the codes are working well enough for you or you have figured how to make any changes you needed, if any.

Howard

tossit2 · Jul 2, 2016

I apologize for late response. I got pulled onto a different project that was screaming louder at the moment. I will be able to get back to this one next week to determine the next step needed. Thank you for being patient with me Howard. You are a tremendous help and encouragement!!!

L. Howard · Jul 2, 2016

Okay, that is fine.

Howard

How do I populate a list on sheet1 from data in various places on different sheets

tossit2

New Member

L. Howard

Well-known Member

Excel Facts

tossit2

New Member

L. Howard

Well-known Member

L. Howard

Well-known Member

L. Howard

Well-known Member

tossit2

New Member

L. Howard

Well-known Member

Similar threads

Forum statistics

Share this page

How do I populate a list on sheet1 from data in various places on different sheets

New Member

Well-known Member

Excel Facts

New Member

Well-known Member

Well-known Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock