Could you check my code please.

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
3,380
Office Version
2007
Platform
Windows
This is the whole code from my worksheet,



When i click the Transfer button it should copy & paste like shown below.

Copy G INCOME cell D31 & paste to G SUMMARY cell D9

Copy G INCOME cell E31 & paste to G SUMMARY cell E9

G INCOME D31 = £200.00 & pastes to G SUMMARY D9 £200.00 "correct"

G INCOME E31 + 50 & pastes to G SUMMARY E9 200 "incorrect" should be 50

Do you see why,as a test in D31 i put £135246 then looked at E9 where i then see 135246


Code:
Option ExplicitPublic PDFExists As Boolean
Private Sub SUMMARYTRANSFER()
    Dim rFndCell As Range
    Dim strData As String
    Dim stFnd As String
    Dim fRow As Long
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim strDate As String


    Set ws = Sheets("G INCOME")
    Set sh = Sheets("G SUMMARY")
    stFnd = ws.Range("A3").Value
    strDate = ws.Range("A5").Value
    With sh
        Set rFndCell = .Range("C5:C17").Find(stFnd, LookIn:=xlValues)
        If Not rFndCell Is Nothing Then
            fRow = rFndCell.Row
            If CDate(strDate) > CDate("05/04/2019") Then
                sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("D31,E31").Value
            Else:
                sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("D31,E31").Value
            End If
            MsgBox "Transfer To Summary Sheet Also Completed", vbInformation + vbOKOnly, "INCOME TRANSFER SHEET MESSAGE"
        Else
            MsgBox "DOES NOT EXIST", vbCritical + vbOKOnly, "SUMMARY TO TRANSFER SHEET FAILED MESSAGE"
            Range("A5").Select
        End If
        Range("A5:B30").ClearContents
        Range("A5").Select
        ActiveWorkbook.Save
    End With
End Sub
Private Sub INCOMETRANSFER()


    Dim strFileName As String
    
        strFileName = "C:\Users\Ian\Desktop\GRASS CUTTING\CURRENT GRASS SHEETS\INCOME 2019-2020\" & _
        Range("D3") & "_" & Format(Month(DateValue(Range("A3") & " 1, " & "2019")), "00") & " " & Range("A3") & ".pdf"


    If Dir(strFileName) <> vbNullString Then
        MsgBox "GRASS CUTTING INCOME SHEET " & Range("A3") & " " & Range("D3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        PDFExists = True
        Exit Sub
    Else
        PDFExists = False
    End If
    
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True
        MsgBox "GRASS CUTTING INCOME SHEET " & Range("A3") & " " & Range("D3") & " WAS SAVED SUCCESSFULLY", vbInformation + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"


    End With


End Sub
Private Sub TransferButton_Click()
    
    Call INCOMETRANSFER
    
    If PDFExists Then
'       Do nothing
    Else
        Call SUMMARYTRANSFER
    End If
    
End Sub


Private Sub Worksheet_Activate()
  Range("A3") = UCase(Format(Now, "mmmm"))
  Range("D3") = Year(Now)
  Range("A1:E3").HorizontalAlignment = xlCenter
  Range("A1:E3").VerticalAlignment = xlCenter
  Range("A1:E30, D31:E31, B35:C37, E35:E37 ").Borders.LineStyle = xlContinuous
  Range("A5").Select
  
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub


On Error Resume Next


If Not Intersect(Target, Range("A1:E38")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True


End If
On Error GoTo 0


End Sub
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
3,380
Office Version
2007
Platform
Windows
Hi,
Still trying to get this right,

I have changed the middle part to the below.


Code:
     If CDate(strDate) > CDate("05/04/2019") Then
            [COLOR=#ff0000]    sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("D31").Value
                sh.Cells(fRow, 5).Resize(, 3).Value = ws.Range("E31").Value[/COLOR]
            Else:
[COLOR=#ff0000]                sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("D31").Value[/COLOR]
[COLOR=#ff0000]                sh.Cells(fRow - 12, 5).Resize(, 3).Value = ws.Range("E31").Value[/COLOR]
            End If
This then gets the correct value on the G SUMMARY PAGE BUT

So i see this

D9 £200.00

E9 50

F9 50

G9 50

Just the D9 & E9 would be nice
 

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
3,380
Office Version
2007
Platform
Windows
Now all sorted.

>Resize needed to be 1
 

Watch MrExcel Video

Forum statistics

Threads
1,102,630
Messages
5,488,004
Members
407,617
Latest member
Samanthad2007

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top