­ã´£³¡ªL

E As Range
For Each E In .Range(.[a1], .[a1].End(xlDown))

next

³o¬q§ï¦¨Array·|¦A¥[§Ö³t«×~~

­ã´£³¡ªL

Sub Ex_01()
Dim xD, Arr, Brr, i&, j%, R&, Tm
Tm = Time
Set xD = CreateObject("scripting.dictionary")
Arr = Range([Data!D1], [Data!A1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Arr): xD(Arr(i, 1) & "") = i: Next
   
Brr = Range([Search!D1], [Search!A1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Brr)
    R = Val(xD(Brr(i, 1) & ""))
    For j = 1 To 3
        Brr(i - 1, j) = "No Data"
        If R > 0 Then Brr(i - 1, j) = Arr(R, j + 1)
    Next j
Next i

[Search!B2:D2].Resize(UBound(Brr) - 1) = Brr
MsgBox Time - Tm
End Sub

­ã´£³¡ªL

¦^´_ 12# Qin

Sub Ex_01()
Dim xD, Arr, Brr, xA As Range, xS As Worksheet, R&, C%, i&, j%
Set xD = CreateObject("scripting.dictionary")
R = [Search!A1].Cells(Rows.Count, 1).End(3).Row
Arr = [Search!A1:O1].Resize(R)
For i = 2 To UBound(Arr, 2):   xD(Arr(1, i) & "") = i - 1:   Next '¼Ð°O[Äæ]¦ì¸m
For i = 2 To UBound(Arr):   xD(Arr(i, 1) & "") = i - 1:   Next  '¼Ð°O[¦C]¦ì¸m
Set xA = [Search!B2:O2].Resize(R - 1)  '¸ê®Æ¶ñ¤J°Ï(§Y­ì¤½¦¡°Ï)
xA = "No Data"  '¹w¥ý¶ñ¤J[No Data], «Ý¦³²Å¦X¦AÂл\
Arr = xA.Value  '±a¤JArray

For Each xS In Sheets(Array("AB", "CD", "EF", "GH", "KL", "MN"))
    Brr = xS.UsedRange
    For i = 2 To UBound(Brr)
        R = Val(xD(Brr(i, 1) & "")): If R = 0 Then GoTo 101
    For j = 2 To UBound(Brr, 2)
        C = Val(xD(xS.Name & "_" & Brr(1, j)))
        If C > 0 Then Arr(R, C) = Brr(i, j)
    Next j
101: Next i
Next
xA.Value = Arr
End Sub

Dictionary_01v.rar (17.7 KB)

¤U¸ü¦¸¼Æ: 22

2018-11-6 14:05

­ã´£³¡ªL

¦^´_ 15# Qin
¢°¡^¦Û°Ê¨ú¹ïÀ³­È
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, xF As Range
With Target
     If .Columns.Count > 1 Or .Column <> 1 Then Exit Sub
     For Each xR In .Cells
         If .Row = 1 Then GoTo 101
         xR(1, 2).Resize(1, 2).ClearContents
         If xR = "" Then GoTo 101
         Set xF = [Sheet1!A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
         If xF Is Nothing Then GoTo 101
         xR(1, 2).Resize(1, 2) = xF(1, 2).Resize(1, 2).Value
101: Next
End With
End Sub

¥i¥H¥u¹ïAÄæ³æ¤@Àx¦s®æ¿é¤J¨ú¹ïÀ³­È, ©Î¤@¦¸¶K¤J¦h­Ó¬d¸ß­È¨ú¹ïÀ³~~
¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð¡Ð
¢±¡^¦r¨åªk¤ñ¹ï¨ú­È
¥u­n§ï¨â­Ó¡]¥[Ucase, ©ÎLcase, ±N­^¤å¦r±j¨îÂର¤j¼g©Î¤p¼g¡^
xD(UCase(Arr(i, 1))) = i
R = Val(xD(UCase(Brr(i, 1))))
¡@
¡@
¡@

­ã´£³¡ªL

¦^´_ 18# Qin

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, xF As Range, xCr, xCf, j%
xCr = Array(3, 6, 7) '¥»ªí­n¶K¤JªºÄæ¦ì
xCf = Array(2, 4, 5) '¨Ó·½ªí­n½Æ»sªºÄæ¦ì
With Target
     If .Columns.Count > 1 Or .Column <> 1 Then Exit Sub
     For Each xR In .Cells
         If .Row = 1 Then GoTo 101
         xR(1, 2).Resize(1, 7).ClearContents
         If xR = "" Then GoTo 101
         Set xF = Sheet1.[A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
         '_Sheet1¬°¨Ó·½ªíªº[ÄݩʦWºÙ], ¤u§@ªí¦WºÙ¥i¥ô·N§ó§ï¦Ó¤£¼vÅT(¨£¤U¹Ï)
         If xF Is Nothing Then GoTo 101
         For j = 0 To UBound(xCr)
             xR(1, xCr(j)) = xF(1, xCf(j)).Value
         Next j
101: Next
End With
End Sub

¤U¸ü (19.68 KB)

2018-11-19 16:41

­ã´£³¡ªL

¦^´_ 20# Qin


Sub CopyPaste()
Dim xA As Range, xB As Workbook, xS As Worksheet, Chk%
Set xA = ActiveSheet.UsedRange
Application.ScreenUpdating = False
Set xB = Workbooks.Open(ThisWorkbook.Path & "\bcca.xls", Password:="1234")
For Each xS In xB.Sheets
    If Left(xS.Name, 6) = "w_PRG_" Then Chk = 1: Exit For
Next
If Chk = 0 Then MsgBox "¤u§@ªí¡ew_PRG¡f¤£¦s¦b¡I¡@": Exit Sub
With xS
    .Unprotect "pass"
    .UsedRange.Clear
     xA.Copy .[A1]
     .UsedRange.Font.Color = vbWhite
     .Name = "w_PRG_" & Format(Date, "yyyymmdd")
     .Protect "pass"
End With
xB.Close 1
MsgBox "½Æ»s§¹¦¨¡I¡@"
End Sub

­ã´£³¡ªL

¦^´_ 22# Qin

¢°¡^­n¥h¤F¸Ñ¨C¤@¦æµ{¦¡½Xªº·N«ä, ¤£µM°Ý¤@°ï·|¨S§¹¨S¤F¡ã¡ã¡ã¡ã
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, xF As Range, xCr, xCf, j%
xCr = Array(3, 6, 7)
xCf = Array(2, 4, 5)
With Target.Columns(1)  '¶K¤J©Î¿é¤J°Ïªº²Ä¤@Äæ
     If .Column <> 1 Then Exit Sub
     For Each xR In .Cells
         If .Row = 1 Then GoTo 101
         xR(1, 3).Resize(1, 5).ClearContents
         If xR = "" Then GoTo 101
         Set xF = Sheet1.[A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
         If xF Is Nothing Then GoTo 101
         For j = 0 To UBound(xCr)
             xR(1, xCr(j)) = xF(1, xCf(j)).Value
         Next j
101: Next
End With
End Sub
¡@
¢±¡^CHANGEIJµoªºµ{¦¡¡A´NµLªk¦A¨Ï¥Î¡e´_­ì¡f¡I
¡@
¡@
¡@