excel - 选择下拉列表时填写数据

Question

我有一个包含 5 张纸的 Excel 文件:

Sheet1是数据输入，

sheet2 = 商店 1，

sheet3 = 商店 2，

sheet4 = 商店 3，

sheet5 = 商店 4，

sheet6 = 商店 5。

在 sheet1我有 4 个变量: Store (5家店铺的下拉列表)， Staff name , Email , Profit .我想将 ActiveX 控件与宏(命令按钮)一起使用。
例如我想当我在 sheet1 中填写数据时并选择“Store 1”并按下按钮，它将数据复制到 sheet2 .
我的代码工作完美，但问题是当我制作更多变量时它会显示错误

Procedure too Large.

我的代码是:

Sub Entry_Click()
    If Sheet1.Range("B4").Value = "" Then MsgBox "Please choose a store": Exit Sub
    
    If Sheet1.Range("B4").Value = "Store 1" Then
    Application.ScreenUpdating = False
        Dim iRow As Long
        iRow = Sheets(2).Range("B1048576").End(xlUp).Row + 1
      
        With ThisWorkbook.Sheets(2)
                  
           .Range("A" & iRow).Value = Sheet1.Range("C4").Value
           .Range("B" & iRow).Value = Sheet1.Range("D4").Value
           .Range("C" & iRow).Value = Sheet1.Range("E4").Value
           
        End With
        Application.ScreenUpdating = True
        
        ElseIf Sheet1.Range("B4").Value = "Store 2" Then
        Application.ScreenUpdating = False
        iRow = Sheets(3).Range("B1048576").End(xlUp).Row + 1
        With ThisWorkbook.Sheets(3)
        
           .Range("A" & iRow).Value = Sheet1.Range("C4").Value
           .Range("B" & iRow).Value = Sheet1.Range("D4").Value
           .Range("C" & iRow).Value = Sheet1.Range("E4").Value
                      
           
        End With
        Application.ScreenUpdating = True
        
        ElseIf Sheet1.Range("B4").Value = "Store 3" Then
        Application.ScreenUpdating = False
        iRow = Sheets(4).Range("B1048576").End(xlUp).Row + 1
        With ThisWorkbook.Sheets(4)
        
           .Range("A" & iRow).Value = Sheet1.Range("C4").Value
           .Range("B" & iRow).Value = Sheet1.Range("D4").Value
           .Range("C" & iRow).Value = Sheet1.Range("E4").Value
                      
           
        End With
        Application.ScreenUpdating = True
        
        ElseIf Sheet1.Range("B4").Value = "Store 4" Then
        Application.ScreenUpdating = False
        iRow = Sheets(5).Range("B1048576").End(xlUp).Row + 1
        With ThisWorkbook.Sheets(5)
        
           .Range("A" & iRow).Value = Sheet1.Range("C4").Value
           .Range("B" & iRow).Value = Sheet1.Range("D4").Value
           .Range("C" & iRow).Value = Sheet1.Range("E4").Value
                      
           
        End With
        Application.ScreenUpdating = True
        
         ElseIf Sheet1.Range("B4").Value = "Store 5" Then
        Application.ScreenUpdating = False
        iRow = Sheets(6).Range("B1048576").End(xlUp).Row + 1
        With ThisWorkbook.Sheets(6)
        
           .Range("A" & iRow).Value = Sheet1.Range("C4").Value
           .Range("B" & iRow).Value = Sheet1.Range("D4").Value
           .Range("C" & iRow).Value = Sheet1.Range("E4").Value
                      
           
        End With
        Application.ScreenUpdating = True
        
        End If
        
End Sub

Answer 1

确保将您的第一张工作表命名为 Data Entry和您的商店表Store 1 , Store 2 , ... 与下拉框中的完全相同。

那么下面的代码应该可以工作。如果您添加更多列进行复制，您只需调整 NumberOfColumns .确保存储表中的列与数据输入表中的列具有相同的顺序。
此代码更加通用，您无需为每张工作表一遍又一遍地重复代码，如果您添加更多商店，也无需更改它。您唯一需要调整的是要复制的列数。

Option Explicit

Public Sub Entry_Click()
    Dim wsDataEntry As Worksheet 'set data entry sheet
    Set wsDataEntry = ThisWorkbook.Worksheets("Data Entry")
    
    Const NumberOfColumns As Long = 3  'number of columns to copy
    
    If wsDataEntry.Range("B4").Value = vbNullString Then
        MsgBox "Please choose a store"
        Exit Sub
    End If
    
    Dim wsSelectedStore As Worksheet
    On Error Resume Next
    'try to find the sheet for the seleced store
    Set wsSelectedStore = ThisWorkbook.Worksheets(wsDataEntry.Range("B4").Value)
    On Error GoTo 0

    'check if the store sheet was found
    If wsSelectedStore Is Nothing Then
        MsgBox "Selected store does not exist"
        Exit Sub
    End If
    
    'find next free row in the store sheet
    Dim NextFreeRow As Long
    NextFreeRow = wsSelectedStore.Cells(wsSelectedStore.Rows.Count, "B").End(xlUp).Row + 1
    
    'copy range C4 (and amount of columns) to next free row in store sheet
    wsSelectedStore.Range("A" & NextFreeRow).Resize(ColumnSize:=NumberOfColumns).Value = wsDataEntry.Range("C4").Resize(ColumnSize:=NumberOfColumns).Value
End Sub