一個關於Excel自動抓取資料填入對應儲存格問題

cs113ta wrote:
土法煉鋼你把那一列...(恕刪)

cs113ta wrote:
土法煉鋼你把那一列...(恕刪)

厄洛斯 wrote:
今天進公司去試過確...(恕刪)

Const SheetName = "客戶清單"   '資料工作表名稱
Const Col = "C1"               '客戶代碼欄位
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count = 1 And Target.Column = Range(Col).Column Then
     Dim List As String
        With Sheets(SheetName)
           List = Unique(.Range(.Cells(2, 2), .Cells(.UsedRange.Rows.Count, 2)))
        End With
        Target.Offset(0, 1).Validation.Delete
        Target.Offset(0, 1).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
        Formula1:=List
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyKey As Integer    '資料階層
    MyKey = Target.Column() - Me.Range(Col).Column + 1
    If Target.Count = 1 And MyKey > 1 And MyKey < 5 Then
        Target.Offset(0, 1).Value = ""
        Target.Offset(0, 1).Validation.Delete
        Target.Offset(0, 1 - MyKey).Value = ""
        If Target.Text <> "" Then
            Dim Rng As Range
            Set Rng = Sheets(SheetName).UsedRange
            Rng.AutoFilter
            If MyKey > 3 Then Rng.AutoFilter Field:=MyKey - 2, Criteria1:=Target.Offset(0, -2).Text
            If MyKey > 2 Then Rng.AutoFilter Field:=MyKey - 1, Criteria1:=Target.Offset(0, -1).Text
            Rng.AutoFilter Field:=MyKey, Criteria1:=Target.Text
            If MyKey < 4 Then
                Target.Offset(0, 1).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
                Formula1:=Unique(Rng.Resize(Rng.Rows.Count - 1, 1).Offset(1, MyKey).SpecialCells(xlCellTypeVisible))
            ElseIf MyKey = 4 Then
                Target.Offset(0, 1 - MyKey) = Rng.Resize(Rng.Rows.Count - 1, 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).Range("A1")
            End If
            Rng.AutoFilter
        End If
    End If
End Sub
Function Unique(DD As Variant) As String   '刪除重複
 Dim D As Variant, Str As String
  For Each D In DD
   If InStr(Str, D) = 0 Then
    Str = IIf(Str = "", D, Str & "," & D)
   End If
  Next D
  Unique = Str
End Function

YS2000 wrote:
用VBA方式 看看...(恕刪)

厄洛斯 wrote:
我試過將您提供的VBA...(恕刪)