excel 在多个相同的工作表之间切换数据,而不会丢失任何数据

ulydmbyx  于 2023-02-20  发布在  其他
关注(0)|答案(1)|浏览(148)

我有一个Excel工作簿,其中有20个以某个住宅的床号命名的选项卡。每个工作表的格式都相同,包含占用该床的个人的人口统计数据。
数据从用户表单输入。
我需要在不要求用户重新输入所有数据的情况下更改床位分配。
我想用两种方法之一解决这个问题:我可以创建一个表格,列出那些占用床位的人的名字,用户将为每个人分配床位号,然后重命名每张表,或者从每张表中提取所有数据,并根据床位变化将其重新插入正确的表中。
我要么需要在工作表之间切换数据而不丢失任何数据,要么基于用户输入重命名所有工作表。

gev0vcfq

gev0vcfq1#

假设你有这样的表格

创建一个类似的数据表,带有加载和保存按钮。

加载将填写数据表从病床表格。重新分配病床列B和保存回表格。我已经包括了基本的错误和验证检查和备份保存后加载增加安全性。

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

相关问题