Need Ideas To Carry Out This Function Please

[charllie]

Hi Folks,

I need some ideas from people how to go about doing the following function. I am sure i would figure it out but i know that there far more experienced people out there who have probably done something similar. If someone can point in the right direction then i can go from there.

Here are the details of the function i want to carry out:

• I have a worksheet1, worksheet2 and worksheet3.
  I Have a commandbutton1 and commandbutton2.
  
  Worksheet1 contains several columns of information (from column A to Q) and can be anything from 1 to 20 pages depending on how busy we are. Each row conatining information for a differnet job.
  
  
  When i activate a commandbutton1 i want to go into worksheet1 and extract the information in columns A, D, F, G, H, I, J, K, AND P (staring at row 2, row 1 contains headers)
  Then place these extarcted columns into worksheet2 in columns A, B, C, D, E, F, G, H and I (again staring at row 2, row 1 contains headers)
  
  So
  
  A is copied to A
  D is copied to B
  F is copied to C
  G is copied to D
  H is copied to E
  I is copied to F
  J is copied to G
  K is copied to H
  P is copied to I
  
  Once the information is transferred into worksheet2 i no longer need worksheet1 until it is updated the next day (updated daily)
  
  Now i am not sure whether worksheet2 should be a worksheet or a listbox because of the following function and so need advice.
  
  Next, I now want to be able to go worksheet2 column I and add a few comments to some of the rows.
  
  Once that is done i now want to be able to choose certain rows from worksheet2 and when commandbutton2 is activated it will transfer the choosen rows from worksheet2 to worksheet3 (staring at row 2, row 1 contains headers).

I would be really grtaefull if someone has the time to help me get started with this. It is a scheduling tool that will be used daily.

All the above worksheets are located in the samework at the moment but when the project goes live they will be in different workbooks. This is not an issue at the moment as i will be able to do that whne the time comes.

Thanks

 

[al_b_cnu]

Hi Mike,

This code will insert an extra menu item 'Transfer' to your workbook, with 'Transfer 1' & 'Transfer 2' menu options.

To install,

1) Create Module1 (or whatever) & insert this code:

Option Explicit

Sub CreateMenu()
    Dim NewMenu As CommandBarPopup, sItemName As String, HelpMenu, MenuItem

'   Delete the menu if it already exists
    Call DeleteMenu
    
'   Find the Help Menu
    Set HelpMenu = CommandBars(1).FindControl(ID:=30010)
    
    If HelpMenu Is Nothing Then
'       Add the menu to the end
        Set NewMenu = CommandBars(1).Controls.Add _
          (Type:=msoControlPopup, _
           temporary:=True)
    Else
'      Add the menu before Help
        Set NewMenu = CommandBars(1).Controls.Add _
          (Type:=msoControlPopup, _
           Before:=HelpMenu.Index, _
           temporary:=True)
    End If

'   Add a caption for the menu
    NewMenu.Caption = "T&ransfer Data"
    
'   FIRST MENU ITEM
    Set MenuItem = NewMenu.Controls.Add _
      (Type:=msoControlButton)
    With MenuItem
        .Caption = "Transfer &1"
        .FaceId = 590
        .OnAction = "Transfer1"
    End With
    
'   NEXT MENU ITEM
    Set MenuItem = NewMenu.Controls.Add _
      (Type:=msoControlButton)
    With MenuItem
        .Caption = "Transfer &2"
        .FaceId = 590
        .OnAction = "Transfer2"
    End With
    
End Sub

Sub DeleteMenu()
    On Error Resume Next
    CommandBars(1).Controls("Budgeting").Delete
End Sub

Sub Transfer1()
Dim iPtr As Integer
Dim lRowEnd As Long
Dim sFr As String, sTo As String
Dim vFrCols As Variant, vToCols As Variant
Dim wsFr As Worksheet, wsTo As Worksheet

Set wsFr = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
vFrCols = Split(expression:="A,D,F,G,H,I,J,K,P", delimiter:=",")
vToCols = Split(expression:="A,B,C,D,E,F,G,H,I", delimiter:=",")

wsTo.Cells.Clear
For iPtr = 0 To UBound(vFrCols)
    sFr = vFrCols(iPtr)
    sTo = vToCols(iPtr)
    lRowEnd = wsFr.Cells(Rows.Count, sFr).End(xlUp).Row
    wsTo.Range(Cells(1, sTo).Address, Cells(lRowEnd, sTo).Address).Value = _
        wsFr.Range(Cells(1, sFr).Address, Cells(lRowEnd, sFr).Address).Value
Next iPtr

End Sub
Sub Transfer2()
Dim bSelected() As Boolean, lCur As Long, lRow As Long
Dim R As Range
Dim wsTo As Worksheet

If ActiveSheet.Name <> "Sheet2" Then
    MsgBox "currently Active sheet not sheet2"
    Exit Sub
End If

Set wsTo = Sheets("Sheet3")
ReDim bSelected(0 To 0)

For Each R In Selection
    lCur = R.Row
    If UBound(bSelected) < lCur Then ReDim Preserve bSelected(0 To lCur)
    bSelected(lCur) = True
Next R

'wsTo.Cells.ClearContents

lRow = wsTo.Cells(Rows.Count, 1).End(xlUp).Row
For lCur = 2 To UBound(bSelected)
    If bSelected(lCur) = True Then
        lRow = lRow + 1
        wsTo.Rows(lRow).Value = ActiveSheet.Rows(lCur).Value
    End If
Next lCur
End Sub

2) in ThisWorkbook, paste this code:

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Msg As String, Ans As Variant
If Not Me.Saved Then
    Msg = "Do you want to save the changes you made to " & Me.Name & "?"
    Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
    Select Case Ans
    Case vbYes
        Me.Save
    Case vbNo
        Me.Saved = True
    Case vbCancel
        Cancel = True
        Exit Sub
    End Select
End If
Call DeleteMenu
End Sub

Private Sub Workbook_Open()
Call CreateMenu
End Sub

Erm forgot to say, before running Transfer2, select rows in Sheet2 as appropriate.

 

[charllie]

Hi Alan,

That is absolutly awesome, just what i am looking for and the idea on the menu bar is brilliant.

I just have one error which i must apologise for. When i first wrote the post i did not notice that some columns were hidden. This has created a small problem with transfer 2.

When i use transfer 2 (Sheet2 to Sheet3) i want the following to happen.

• A (Sheet2) is copied to A (Sheet3)
  F is copied to B
  B is copied to C
  C is copied to D
  I is copied to E

Will this be too much of a problem to change?

I tried playing around with this part:

vFrCols = Split(expression:="A,D,F,G,H,I,J,K,P", delimiter:=",") 
vToCols = Split(expression:="A,B,C,D,E,F,G,H,I", delimiter:=",")

But didn't work so left well alone.


Thanks

 

[al_b_cnu]

Hi Mike,

Try replacing Transfer2 with this:

Sub Transfer2()
Dim bSelected() As Boolean, iPtr As Integer, lCur As Long, lRow As Long
Dim R As Range
Dim vFrCols As Variant, vData() As Variant
Dim wsTo As Worksheet

If ActiveSheet.Name <> "Sheet2" Then
    MsgBox "currently Active sheet not sheet2"
    Exit Sub
End If

Set wsTo = Sheets("Sheet3")
ReDim bSelected(0 To 0)

For Each R In Selection
    lCur = R.Row
    If UBound(bSelected) < lCur Then ReDim Preserve bSelected(0 To lCur)
    bSelected(lCur) = True
Next R

'wsTo.Cells.ClearContents

vFrCols = Split(expression:="A,F,B,C,I", delimiter:=",")
ReDim vData(1 To UBound(vFrCols) + 1)
lRow = wsTo.Cells(Rows.Count, 1).End(xlUp).Row
For lCur = 2 To UBound(bSelected)
    If bSelected(lCur) = True Then
        lRow = lRow + 1
        For iPtr = 0 To UBound(vFrCols)
            vData(iPtr + 1) = Cells(lCur, vFrCols(iPtr)).Value
        Next iPtr
        wsTo.Range("A" & lRow, Cells(lRow, UBound(vData)).Address).Value = vData
    End If
Next lCur
End Sub

 

[charllie]

Hi Alan,

Tha works brillintly. I even managed to add another button myself following your code. And it works

Thanks for the help i really appreciate it.

Mike

 

[charllie]

Hi Alan,

I don't know if this is easy to do, if not then don't bother.

When "Transfer 1" is activated which transfer from sheet1 to sheet2 it puts all the alignment out on sheet2.

Is there a code i could slip in that tells it to keep sheet2 alignment and bold etc as it is and not to change it.

If it means a lot of changing then don't worry.

Thanks

 

[al_b_cnu]

Hi mike,

In Transfer1, change the statement

wsTo.Cells.Clear

to

wsTo.Cells.Clearcontents

 

[charllie]

Hi Alan,

Thanks. I will give this a try.

Mike