Option Explicit
Private Sub btnLoad_Click()
Dim ws As Worksheet, wsData As Worksheet, r As Long
Dim b As Long, c As Long, lastcol As Long, addr As String
Set wsData = Sheets("Data")
lastcol = wsData.Cells(2, Columns.Count).End(xlToLeft).Column
For Each ws In Sheets
If ws.Name Like "Bed #*" Then
b = CLng(Mid(ws.Name, 4))
r = b + 3
wsData.Cells(r, "B") = b
For c = 3 To lastcol
addr = wsData.Cells(2, c)
wsData.Cells(r, c) = ws.Range(addr).Value2
Next
End If
Next
' save backup
With Application
.ScreenUpdating = False
.DisplayAlerts = False
wsData.Copy
ActiveWorkbook.SaveAs Filename:="Data_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close False
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Private Sub btnSave_Click()
Dim ws As Worksheet, wsData As Worksheet, msg As String
Dim b As Long, c As Long, lastcol As Long, addr As String
' get allocations bed to data row
Dim dict, r As Long
Set dict = CreateObject("Scripting.Dictionary")
For r = 4 To 13
If Not IsNumeric(Sheets("Data").Cells(r, "B")) Then
MsgBox "Invalid bed no" & b, vbCritical, r
Exit Sub
End If
b = Sheets("Data").Cells(r, "B")
' sanity check
If dict.exists(b) Then
MsgBox "Duplicate bed " & b, vbCritical, r
Exit Sub
ElseIf b < 1 Or b > 20 Then
MsgBox "Invalid bed no " & b, vbCritical, r
Exit Sub
Else
dict.Add b, r
End If
Next
Set wsData = Sheets("Data")
lastcol = wsData.Cells(2, Columns.Count).End(xlToLeft).Column
For Each ws In Sheets
If ws.Name Like "Bed #*" Then
b = CLng(Mid(ws.Name, 4))
r = dict(b) ' data row from dictonary
' is there a change
If r <> b + 3 Then
For c = 3 To lastcol
addr = wsData.Cells(2, c)
ws.Range(addr).Value2 = wsData.Cells(r, c)
Next
msg = msg & vbLf & "Bed " & b
End If
End If
Next
If msg = "" Then
MsgBox "No changes made", vbInformation
Else
MsgBox "Changes made to " & msg, vbInformation
End If
End Sub
1条答案
按热度按时间gev0vcfq1#
假设你有这样的表格
创建一个类似的数据表,带有加载和保存按钮。
加载将填写数据表从病床表格。重新分配病床列B和保存回表格。我已经包括了基本的错误和验证检查和备份保存后加载增加安全性。