Problems with VBA code

[jose001]

Hi everyone, I'm not sure whether this is an obvious problem but I have a userform and some button code in excel, which on my machine and a few others in the office runs fine, but on a select few doesn't work. There is a Datepicker on one of the forms so I thought that might be the problem but in some cases that works fine and its the button code that fails! Several of you have helped me over the last few weeks with snippets of code which I have bastardised and maybe thats the problem! I have pasted the code from my forms and button below. If anyone could spare a few minutes to read through and check the code for obvious errors or suggest a way to tidy it up I would really appreciate any help you could give. Thanks a lot.

The userform has two parts...

First Screen

Private Sub cmdAdd_Click()
Dim iRow As Long
Dim NewSheet As Worksheet
Set NewSheet = Worksheets.Add
NewSheet.Name = txtInitiative.Value

'Enter Headers
With Range("A1:H1")
    .Value = Array("Initiative", "Current State", "Future State", "Actions", "Deadlines", "Status", "Lead Admin", "Project Manager")
    With .Font
        .Name = "Verdana"
        .Size = 10
        .bold = True
    End With
    With .Interior
        .ColorIndex = 37
        .Pattern = xlSolid
    End With
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .EntireColumn.AutoFit
End With
    Columns("A:H").Select
    Selection.ColumnWidth = 18.71
    Selection.ColumnWidth = 20.57
    Selection.ColumnWidth = 22.43
    Range("A1").Select


'find first empty row in sheet
iRow = NewSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

'copy the data to the sheet
NewSheet.Cells(iRow, 1).Value = Me.txtInitiative.Value
NewSheet.Cells(iRow, 2).Value = Me.txtCurrentstate.Value
NewSheet.Cells(iRow, 3).Value = Me.txtFuturestate.Value
NewSheet.Cells(iRow, 7).Value = Me.txtLeadadmin.Value
NewSheet.Cells(iRow, 8).Value = Me.txtProjectmngr.Value

Range("F2:F7").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="Active,Complete,Deferred"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With


frmPartLoc.Hide

frmPartLoc2.Show


End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub

Code for second screen

Private Sub cmdAddInitiative_Click()
Dim LimitD As Long

Range("D2").Select

'copy data to sheet
Range("D2").Value = Me.txtAction1.Value
Range("E2").Select
Range("E2").Value = DTPicker1.Value
Range("D3").Select
Range("D3").Value = Me.txtAction2.Value
Range("E3").Select
Range("E3").Value = DTPicker2.Value
Range("D4").Select
Range("D4").Value = Me.txtAction3.Value
Range("E4").Select
Range("E4").Value = DTPicker3.Value
Range("D5").Select
Range("D5").Value = Me.txtAction4.Value
Range("E5").Select
Range("E5").Value = DTPicker4.Value
Range("D6").Select
Range("D6").Value = Me.txtAction5.Value
Range("E6").Select
Range("E6").Value = DTPicker5.Value
Range("D7").Select
Range("D7").Value = Me.txtAction6.Value
Range("E7").Select
Range("E7").Value = DTPicker6.Value

'Formating
LimitD = Cells(Rows.Count, 4).End(xlUp).Row
Range("B2:B" & LimitD).MergeCells = True
Range("C2:C" & LimitD).MergeCells = True
Range("A2:A" & LimitD).Value = Range("A2").Value

Range("E2:E100").Select
Selection.NumberFormat = "m/d/yyyy"

'Wrap Text
Range("A2:H7").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    
    Range("A1").Select



Unload frmPartLoc

MsgBox "Thank you for setting up the Initiative " & ActiveSheet.Name & ". Please keep this up to date as Actions are completed"

Unload Me

End Sub


Private Sub cmdClose_Click()
Unload Me
End Sub

And here is the code attached to a button on a separate sheet which pulls information from all the other sheets in the workbook

Sub TransferData()
Dim i As Long: i = 6
    Range("B6:E4000").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlBottom).LineStyle = xlNone
    Selection.ClearContents
  
For Each sh In Worksheets
    If sh.Name <> "Actions" And sh.Name <> "summary" Then
        Worksheets("Actions").Range("B" & i).Value = sh.Range("A2").Value
        Worksheets("Actions").Range("C" & i).Value = sh.Range("D2").Value
        Worksheets("Actions").Range("D" & i).Value = sh.Range("E2").Value
        Worksheets("Actions").Range("E" & i).Value = sh.Range("F2").Value
        Worksheets("Actions").Range("C" & i + 1).Value = sh.Range("D3").Value
        Worksheets("Actions").Range("D" & i + 1).Value = sh.Range("E3").Value
        Worksheets("Actions").Range("E" & i + 1).Value = sh.Range("F3").Value
        Worksheets("Actions").Range("C" & i + 2).Value = sh.Range("D4").Value
        Worksheets("Actions").Range("D" & i + 2).Value = sh.Range("E4").Value
        Worksheets("Actions").Range("E" & i + 2).Value = sh.Range("F4").Value
        Worksheets("Actions").Range("C" & i + 3).Value = sh.Range("D5").Value
        Worksheets("Actions").Range("D" & i + 3).Value = sh.Range("E5").Value
        Worksheets("Actions").Range("E" & i + 3).Value = sh.Range("F5").Value
        Worksheets("Actions").Range("C" & i + 4).Value = sh.Range("D6").Value
        Worksheets("Actions").Range("D" & i + 4).Value = sh.Range("E6").Value
        Worksheets("Actions").Range("E" & i + 4).Value = sh.Range("F6").Value
        Worksheets("Actions").Range("C" & i + 5).Value = sh.Range("D7").Value
        Worksheets("Actions").Range("D" & i + 5).Value = sh.Range("E7").Value
        Worksheets("Actions").Range("E" & i + 5).Value = sh.Range("F7").Value
        Worksheets("Actions").Range("B" & i & ":E" & i).Select
 With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
        i = i + 6
End If
Next sh
   
    'Highlight Active
    Range("D6:E4000").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=AND($D6<TODAY(),$E6=""Active"")"
    Selection.FormatConditions(1).Interior.ColorIndex = 3
    
    'Format Date
    Range("D2:D4000").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    End With
    
    'Align B-C left
    Range("B6:C4000").Select
    With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    End With
        
    'Deselect all
    Range("B6").Select
    
End Sub

 

[Norie]

And the problem is?

PS You don't need all that selecting.

For example.

'copy data to sheet
For I = 2 To 7
    Range("D" & I).Value = Me.Controls("txtAction" & I - 1).Value
    Range("E" & I).Value = Me.Controls("DTPicker" & I - 1).Value
Next I