在多個相同作業表之間切換資料而不會丟失任何資料-有解無憂

我有一個 ecxel 作業簿，其中有 20 個以住宅床號命名的選項卡。每張床單的格式相同，并包含占用床位的個人的人口統計資料。資料是從用戶表單輸入的。我需要一個解決方案來更改床位分配，而無需用戶重新輸入所有資料。我曾想過以兩種方式之一來解決這個問題。我可以創建一個表格，列出占用床位的人的姓名，用戶將為每個人分配床號，然后重命名每張床單。或者從每張床單中提取所有資料，然后根據床的變化將其重新插入正確的床單。如果這令人困惑，我深表歉意。我通常可以找到答案，但我什至不確定如何問這個問題。

uj5u.com熱心網友回復：

假設你有這樣的表格

在多個相同作業表之間切換資料而不會丟失任何資料

創建一個資料表，如加載和保存按鈕。

在多個相同作業表之間切換資料而不會丟失任何資料

負載將從床單中填寫資料表。重新分配 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

轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/419963.html

標籤：

上一篇：生成PDFVBA時洗掉列

下一篇：基于兩列的日期順序中的第N次出現