Sub Copy_Data()
Dim hh As Worksheet, exist As Boolean, h As Worksheet, sh As Worksheet
Dim f As Range
Set hh = Sheets("Form")
If hh.Range("d5") = "" Then
MsgBox "Please select the year", vbCritical
Exit Sub
End If
If hh.Range("d6") = "" Then
MsgBox "Please select the month", vbCritical
Exit Sub
End If
exist = False
For Each h In Sheets
If LCase(h.Name) = LCase(hh.Range("d5").Value) Then
Set sh = h
exist = True
Exit For
End If
Next
If exist = False Then
MsgBox "The sheet does not exist", vbCritical
Exit Sub
End If
Set f = sh.Range("D2:O2").Find(hh.Range("d6").Value, , xlValues, xlWhole)
If f Is Nothing Then
MsgBox "The month cannot be found", vbCritical
Else
'Top Form'
'cell destination cell origin
sh.Cells(5, f.Column).Value = hh.Range("d10").Value
sh.Cells(6, f.Column).Value = hh.Range("d11").Value
sh.Cells(10, f.Column).Value = hh.Range("d12").Value
sh.Cells(13, f.Column).Value = hh.Range("d14").Value
sh.Cells(14, f.Column).Value = hh.Range("d15").Value
sh.Cells(18, f.Column).Value = hh.Range("d16").Value
sh.Cells(21, f.Column).Value = hh.Range("d18").Value
sh.Cells(22, f.Column).Value = hh.Range("d19").Value
sh.Cells(27, f.Column).Value = hh.Range("d23").Value
sh.Cells(28, f.Column).Value = hh.Range("d24").Value
sh.Cells(29, f.Column).Value = hh.Range("d25").Value
sh.Cells(31, f.Column).Value = hh.Range("d27").Value
sh.Cells(32, f.Column).Value = hh.Range("d28").Value
sh.Cells(33, f.Column).Value = hh.Range("d29").Value
sh.Cells(37, f.Column).Value = hh.Range("d33").Value
sh.Cells(38, f.Column).Value = hh.Range("d34").Value
sh.Cells(41, f.Column).Value = hh.Range("d36").Value
sh.Cells(42, f.Column).Value = hh.Range("d37").Value
sh.Cells(47, f.Column).Value = hh.Range("d41").Value
sh.Cells(48, f.Column).Value = hh.Range("d42").Value
sh.Cells(49, f.Column).Value = hh.Range("d43").Value
sh.Cells(51, f.Column).Value = hh.Range("d45").Value
sh.Cells(52, f.Column).Value = hh.Range("d46").Value
sh.Cells(53, f.Column).Value = hh.Range("d47").Value
sh.Cells(57, f.Column).Value = hh.Range("d51").Value
sh.Cells(58, f.Column).Value = hh.Range("d52").Value
sh.Cells(59, f.Column).Value = hh.Range("d53").Value
sh.Cells(60, f.Column).Value = hh.Range("d54").Value
sh.Cells(61, f.Column).Value = hh.Range("d55").Value
sh.Cells(62, f.Column).Value = hh.Range("d56").Value
sh.Cells(63, f.Column).Value = hh.Range("d57").Value
sh.Cells(64, f.Column).Value = hh.Range("d58").Value
sh.Cells(65, f.Column).Value = hh.Range("d59").Value
sh.Cells(66, f.Column).Value = hh.Range("d60").Value
sh.Cells(67, f.Column).Value = hh.Range("d61").Value
sh.Cells(68, f.Column).Value = hh.Range("d62").Value
sh.Cells(70, f.Column).Value = hh.Range("d64").Value
sh.Cells(71, f.Column).Value = hh.Range("d65").Value
sh.Cells(72, f.Column).Value = hh.Range("d66").Value
sh.Cells(73, f.Column).Value = hh.Range("d67").Value
sh.Cells(74, f.Column).Value = hh.Range("d68").Value
sh.Cells(75, f.Column).Value = hh.Range("d69").Value
sh.Cells(76, f.Column).Value = hh.Range("d70").Value
sh.Cells(77, f.Column).Value = hh.Range("d71").Value
sh.Cells(78, f.Column).Value = hh.Range("d72").Value
sh.Cells(79, f.Column).Value = hh.Range("d73").Value
sh.Cells(80, f.Column).Value = hh.Range("d74").Value
sh.Cells(81, f.Column).Value = hh.Range("d75").Value
End If
End Sub
Sub SelectUnlockedCells()
Dim WorkRange As Range
Dim FoundCells As Range
Dim Cell As Range
Set WorkRange = ActiveSheet.UsedRange
If MsgBox("Are you sure you want to clear this form?", _
vbYesNo + vbQuestion, "Clear Form") = vbYes Then
For Each Cell In WorkRange
If Cell.Locked = False Then
If FoundCells Is Nothing Then
Set FoundCells = Cell
Else
Set FoundCells = Union(FoundCells, Cell)
End If
End If
Next Cell
If FoundCells Is Nothing Then
MsgBox "All cells are locked."
Else
FoundCells.ClearContents
End If
End If
ActiveSheet.Range("d5").Select
End Sub
Sub Route()
Call Copy_Data
Call SelectUnlockedCells
End Sub
Many thanks for any help.
Bookmarks