lovenice831

¦^´_ 18# n7822123
Dim Arr, RepNo$

Sub ³]¤U©Ô¿ï³æ()
Application.ScreenUpdating = False
On Error GoTo «ì´_
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
  RepNo = Arr(R, 13)
  If D(RepNo) = 0 Then D(RepNo) = R
Next R
For Each Key In D.keys: §å¸¹¦ê = §å¸¹¦ê & "," & Key: Next Key
With ['Receiving Report'!J6].Validation
  .Delete
  .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=§å¸¹¦ê
End With
Exit Sub
«ì´_: ¶}±ÒIJµo¨Æ¥ó
End Sub
½Ð°Ý³o­Ó§å¸¹¦ê¬O¥X¦Û¨º¸Ì¡A¦]¬°§Ú¸Õ§â¨º¼Æ¦r²ÕÂন§Oªº²Õ¦X¡Aµo²{­^¤å+¼Æ¦rªº²Õ¦X¥i¦æ¡A¹³apr 0001, ¦ý¦p­Y¥u0001©Î¬O aaa-01/12-0001 ³oºØ«K¤£¦æ¡A³o­Ó§Ú¹Á¸Õ¤J®æ¦¡´«±¼[§å¸¹¦ê]¡M¤]¬O¤£¦æ¡A¬O§_³oºØ»yªk¥»¨Ó´N¤£¥i¥HÅܧ諸©O?

lovenice831

¦^´_ 19# n7822123


¬Ý¨ì³øªí¤Q¤À¿E°Ê¡A¯uªº«ÜÁÂÁ§A {:3_59:} {:3_59:}

n7822123

¦^´_ 15# lovenice831


·wÀY¤F¡A¯uªº«Ü²Ê¤ß....¡A¦¬³fªO¼Æ¨S§ï¨ì¡A§ï¤@¤Uµ{¦¡¦ì¸m

Rn = UBound(Brr)
On Error Resume Next
XX% = UBound(Brr, 2)   '·íBrr=1ºû°}¦C¡A·|¸õ¿ù»~
If Err <> 0 Then Rn = 1  '¿ù»~®É¡A³]Rn=1
On Error GoTo 0
[G13] = Rn

Àɮצp¤U

test Receiving Data 2021-0105-NEW.rar (55.78 KB)

¤U¸ü¦¸¼Æ: 20

2021-1-5 03:18

n7822123

¦^´_ 17# n7822123

µo²{§Úªºµ{¦¡Bug¡A·í¸Ó³ø§i½s¸¹ªº¸ê®Æ­è¦n¥u¦³¤@µ§®É¡A·|¦³°ÝÃD(°}¦CÂà¸m·|Åܦ¨1ºû°}¦C)

­×§ï¦p¤Uµ{¦¡¡A³o¦¸À³¸Ó¥i¥Hº¡¨¬§Aªº»Ý¨D~ ¥\¯à¦p¤U

ÂI¿ï ³ø§i­¶ªº J6 Àx¦s®æ ¡A·|¦Û°Ê¨Ì Data­¶ ªº "Receiving Report No" ²£¥Í¤U©Ô¦¡¿ï³æ

¿ï¾Ü¦n "Reference No" (J6)«á¡A·|¦Û°Ê²£¥Í³ø§i(¥t°µ·s¤u§@ªí¡A¤£§ï½d¥»®æ¦¡¡AÁקK­«½Æ°õ¦æ·|¦³°ÝÃD)


IJµo¨Æ¥ó-¦Û°ÊIJµoµ{¦¡¡A½Ð½Æ»s¶K¤W¨ì "Receiving Report" ¤u§@ªí¸Ì­±

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row = 6 And Target.Column = 10 Then
  Application.EnableEvents = False
  Call ³]¤U©Ô¿ï³æ
  Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 6 And Target.Column = 10 Then
  Application.EnableEvents = False
  Call ¦¬³f³øªí_³æ¿ï
  Application.EnableEvents = True
End If
End Sub

¤@¯ë¼Ò²Õµ{¦¡¡A½ÐÀH«K³Ð¤@­Ó¼Ò²Õ¶K¤Wµ{¦¡§Y¥i

Dim Arr, RepNo$
Sub ³]¤U©Ô¿ï³æ()
Application.ScreenUpdating = False
On Error GoTo «ì´_
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
  RepNo = Arr(R, 13)
  If D(RepNo) = 0 Then D(RepNo) = R
Next R
For Each Key In D.keys: §å¸¹¦ê = §å¸¹¦ê & "," & Key: Next Key
With ['Receiving Report'!J6].Validation
  .Delete
  .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=§å¸¹¦ê
End With
Exit Sub
«ì´_: ¶}±ÒIJµo¨Æ¥ó
End Sub

Sub ¦¬³f³øªí_³æ¿ï()
Dim Brr(), R0%, R&, K%, D As Object
Application.ScreenUpdating = False
On Error GoTo «ì´_
RepNo = ['Receiving Report'!J6]
If RepNo = "" Then Exit Sub
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
  If D(Arr(R, 13) & "") = 0 Then D(Arr(R, 13) & "") = R
Next R
R0 = D(RepNo): ·sªí R0
For R = R0 To UBound(Arr)
    K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
    Brr(1, K) = Arr(R, 9)     '³fª«¦WºÙ
    Brr(3, K) = Arr(R, 5)     '§å¸¹
    Brr(4, K) = Arr(R, 7)     'ªO¸¹
    Brr(5, K) = Arr(R, 8)     '½c¸¹
    Brr(8, K) = Arr(R, 10)   '¹êª«¦¬³f
    If R + 1 > UBound(Arr) Then ¥t¦s·sÀÉ Brr: Exit For
    If Arr(R + 1, 13) <> RepNo Then ¥t¦s·sÀÉ Brr: Exit For
Next R: Erase Arr: Erase Brr
Exit Sub
«ì´_: ¶}±ÒIJµo¨Æ¥ó
End Sub

Sub ¦¬³f³øªí_§å¦¸()
Dim Brr(), R&, K%
Application.ScreenUpdating = False
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
    If Arr(R, 13) <> RepNo Then ·sªí R: RepNo = Arr(R, 13): K = 0
    K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
    Brr(1, K) = Arr(R, 9)     '³fª«¦WºÙ
    Brr(3, K) = LotNo        '§å¸¹
    Brr(4, K) = Arr(R, 7)     'ªO¸¹
    Brr(5, K) = Arr(R, 8)     '½c¸¹
    Brr(8, K) = Arr(R, 10)   '¹êª«¦¬³f
    If R + 1 > UBound(Arr) Then ¥t¦s·sÀÉ Brr: Exit For
    If Arr(R + 1, 13) <> RepNo Then ¥t¦s·sÀÉ Brr
Next R: Erase Arr: Erase Brr
Sheets("Receiving DATA").Activate
End Sub

Sub ·sªí(ByVal R)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Receiving Report").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("Reference No " & Arr(R, 13)).Delete
On Error GoTo 0
ActiveSheet.Name = "Reference No " & Arr(R, 13)
[C10] = Int(Arr(R, 2))        '¦¬³f¤é´Á
[F10] = Arr(R, 2) - [C10]   '¦¬³f®É¶¡
[C11] = Arr(R, 3)                'Âd¸¹/³f¨®¨®µP
[J6] = Arr(R, 13)                  'Reference No:
[J8] = Arr(R, 5)                    'Lot Number
[J10] = Arr(R, 11)                'PO No.
[J11] = Arr(R, 14)                'BD ­t³d¤H
[G11] = Arr(R, 4)                 '«Ê±ø¸¹
§R°£·sªíIJµo¨Æ¥ó ActiveSheet.CodeName
[J6].Validation.Delete
End Sub

Sub ¥t¦s·sÀÉ(ByVal Brr)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
Brr = Application.Transpose(Brr)  '·íBrr¸ê®Æ¥u¦³¤@µ§¡AÂà¸m«áÅÜ1ºû°}¦C
Rn = UBound(Brr): [G13] = Rn
On Error Resume Next
XX% = UBound(Brr, 2)   '·íBrr=1ºû°}¦C¡A·|¸õ¿ù»~
If Err <> 0 Then Rn = 1  '¿ù»~®É¡A³]Rn=1
On Error GoTo 0
If Rn >= 4 Then
  Rows("21:" & 21 + Rn - 4).Insert Shift:=4
  Rows(20).Copy
  Rows("21:" & 21 + Rn - 4).Select
  ActiveSheet.Paste
End If: [A10].Select
Application.CutCopyMode = False
[A19].Resize(Rn, 11) = Brr
[H13] = WorksheetFunction.Sum([E19].Resize(Rn))
ActiveSheet.Copy
With ActiveSheet
  .Parent.SaveAs MyPath & .Name & ".xls", xlNormal
  .Parent.Close 1
End With
'ActiveSheet.Delete
End Sub

Sub §R°£·sªíIJµo¨Æ¥ó(ByVal ·sªíCodeNm)
Application.DisplayAlerts = False
With ThisWorkbook.VBProject
  For Each vbx In .VBComponents
    If vbx.Name = ·sªíCodeNm Then
      With vbx.CodeModule: .DeleteLines 1, .CountOfLines: End With
    End If
  Next
End With
End Sub

Sub ¶}±ÒIJµo¨Æ¥ó()
Application.EnableEvents = True
End Sub

Àɮצp¤U

test Receiving Data 2021-0105.rar (55.67 KB)

¤U¸ü¦¸¼Æ: 4

2021-1-5 02:59

n7822123

¦^´_ 15# lovenice831


­ì¨Ó§Aªº "Reference No:"  ¬O«ü Data­¶ªº "Receiving Report No."

§Ú¤j·§ª¾¹D§A­n·F¹À¤F¡A¥Î§Ú¤§«eªºÀɮקﵹ§A

ÂI¿ï ³ø§i­¶ªº [J6] ¦Û°Ê¨Ì Data­¶ ªº Receiving Report No ²£¥Í¤U©Ô¦¡¿ï³æ

¿ï¾Ü¦n "Reference No" «á¡A¦Û°Ê²£¥Í³ø§i(¥t°µ·s¤u§@ªí¡A¤£§ï½d¥»®æ¦¡¡AÁקK­«½Æ°õ¦æ·|¦³°ÝÃD)

¦P¸ô®|¤U¤]·|²£¥Í¸Ó³ø§iªºÀÉ®× ¡A¥ý¶Kµ{¦¡¦p¤U


IJµo¨Æ¥ó-¦Û°ÊIJµoµ{¦¡¡A½Ð½Æ»s¶K¤W¨ì "Receiving Report" ¤u§@ªí¸Ì­±

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row = 6 And Target.Column = 10 Then
  Application.EnableEvents = False
  Call ³]¤U©Ô¿ï³æ
  Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 6 And Target.Column = 10 Then
  Application.EnableEvents = False
  Call ¦¬³f³øªí_³æ¿ï
  Application.EnableEvents = True
End If
End Sub


¤@¯ë¼Ò²Õµ{¦¡¡A½ÐÀH«K³Ð¤@­Ó¼Ò²Õ¶K¤Wµ{¦¡§Y¥i

Dim Arr, RepNo$

Sub ³]¤U©Ô¿ï³æ()
Application.ScreenUpdating = False
On Error GoTo «ì´_
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
  RepNo = Arr(R, 13)
  If D(RepNo) = 0 Then D(RepNo) = R
Next R
For Each Key In D.keys: §å¸¹¦ê = §å¸¹¦ê & "," & Key: Next Key
With ['Receiving Report'!J6].Validation
  .Delete
  .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=§å¸¹¦ê
End With
Exit Sub
«ì´_: ¶}±ÒIJµo¨Æ¥ó
End Sub

Sub ¦¬³f³øªí_³æ¿ï()
Dim Brr(), R0%, R&, K%, D As Object
Application.ScreenUpdating = False
On Error GoTo «ì´_
Arr = ['Receiving DATA'!A4].CurrentRegion
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
  RepNo = Arr(R, 13)
  If D(RepNo) = 0 Then D(RepNo) = R
Next R
RepNo = ['Receiving Report'!J6]
If RepNo = "" Then Exit Sub
R0 = D(RepNo): ·sªí R0
For R = R0 To UBound(Arr)
    K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
    Brr(1, K) = Arr(R, 9)     '³fª«¦WºÙ
    Brr(3, K) = Arr(R, 5)     '§å¸¹
    Brr(4, K) = Arr(R, 7)     'ªO¸¹
    Brr(5, K) = Arr(R, 8)     '½c¸¹
    Brr(8, K) = Arr(R, 10)   '¹êª«¦¬³f
    If R + 1 > UBound(Arr) Then ¥t¦s·sÀÉ Brr: Exit For
    If Arr(R + 1, 5) <> LotNo Then ¥t¦s·sÀÉ Brr: Exit For
Next R: Erase Arr: Erase Brr
A = 10 / 0
Exit Sub
«ì´_: ¶}±ÒIJµo¨Æ¥ó
End Sub

Sub ¦¬³f³øªí_§å¦¸()
Dim Brr(), R&, K%
Application.ScreenUpdating = False
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
    If Arr(R, 5) <> LotNo Then ·sªí R: LotNo = Arr(R, 5): K = 0
    K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
    Brr(1, K) = Arr(R, 9)     '³fª«¦WºÙ
    Brr(3, K) = LotNo        '§å¸¹
    Brr(4, K) = Arr(R, 7)     'ªO¸¹
    Brr(5, K) = Arr(R, 8)     '½c¸¹
    Brr(8, K) = Arr(R, 10)   '¹êª«¦¬³f
    If R + 1 > UBound(Arr) Then ¥t¦s·sÀÉ Brr: Exit For
    If Arr(R + 1, 5) <> LotNo Then ¥t¦s·sÀÉ Brr
Next R: Erase Arr: Erase Brr
Sheets("Receiving DATA").Activate
End Sub

Sub ·sªí(ByVal R)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Receiving Report").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("Reference No " & Arr(R, 13)).Delete
On Error GoTo 0
ActiveSheet.Name = "Reference No " & Arr(R, 13)
[C10] = Int(Arr(R, 2))        '¦¬³f¤é´Á
[F10] = Arr(R, 2) - [C10]   '¦¬³f®É¶¡
[C11] = Arr(R, 3)                'Âd¸¹/³f¨®¨®µP
[J6] = Arr(R, 13)                  'Reference No:
[J8] = Arr(R, 5)                    'Lot Number
[J10] = Arr(R, 11)                'PO No.
[J11] = Arr(R, 14)                'BD ­t³d¤H
[G11] = Arr(R, 4)                 '«Ê±ø¸¹
§R°£·sªíIJµo¨Æ¥ó ActiveSheet.CodeName
End Sub

Sub ¥t¦s·sÀÉ(ByVal Brr)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
Brr = Application.Transpose(Brr)
Rn = UBound(Brr): [G13] = Rn
If Rn >= 4 Then
  Rows("21:" & 21 + Rn - 4).Insert Shift:=4
  Rows(20).Copy
  Rows("21:" & 21 + Rn - 4).Select
  ActiveSheet.Paste
End If: [A10].Select
Application.CutCopyMode = False
[A19].Resize(Rn, 11) = Brr
[H13] = WorksheetFunction.Sum([E19].Resize(Rn))
ActiveSheet.Copy
With ActiveSheet
  .Parent.SaveAs MyPath & .Name & ".xls", xlNormal
  .Parent.Close 1
End With
'ActiveSheet.Delete
End Sub

Sub §R°£·sªíIJµo¨Æ¥ó(ByVal ·sªíCodeNm)
Application.DisplayAlerts = False
With ThisWorkbook.VBProject
  For Each vbx In .VBComponents
    If vbx.Name = ·sªíCodeNm Then
      With vbx.CodeModule: .DeleteLines 1, .CountOfLines: End With
    End If
  Next
End With
End Sub

Sub ¶}±ÒIJµo¨Æ¥ó()
Application.EnableEvents = True
End Sub



Àɮצp¤U

test Receiving Data 2021-0104(New).rar (54.08 KB)

¤U¸ü¦¸¼Æ: 2

2021-1-5 01:54

n7822123

¦^´_ 15# lovenice831

µ{¦¡¤ñ¹ï¤À¤j¤p¼g

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$J$6" Then
        Call Update
    End If
End Sub

lovenice831

§Ú¸ÕµÛ¥Î REPORT ¤¤ªº J6 ®æ§ï¦¨¤U©Ô²M³æ¡A½d³ò¬O³øªíªº¤W¥b³¡¥÷¡A¬Ýºô¤Wµu¤ù½d¨Ò·í§ïÅܲM³æ«á¸ê®Æ·|¦Û°Ê¸õ¥X¬ÛÀ³¸ê®Æ¡A¦ý»yªk¤£ª¾¥X¤F¤°»ò°ÝÃD¡A¤£·|¦Û¤v¸õÂà¡A¦³ªB¤Í¯àÀ°¦£¬Ý¬Ý¶Ü?

test Receiving Data 0104.rar (83.4 KB)

¤U¸ü¦¸¼Æ: 6

2021-1-4 09:22

lovenice831

¦^´_ 12# n7822123


    ÁÂÁÂ

lovenice831

¦^´_ 10# ­ã´£³¡ªL


   ¤£¥Î¡A¨º¨Ç³£¤£¥Î¿ïªº¡A©Ò¥H¤£¥Î°Ê¨º´X­ÓÀx¦s®æ

n7822123

¦^´_ 11# n7822123

¤W¼ÓªºÀɮסA¥k¤W"X"ªºÃö³¬ªí³æÅ޿観¨Ç°ÝÃD

½Ð¥Î¤U­±¦¹ÀÉ


test Receiving Data 2021-0101(NEW).rar (69.7 KB)

¤U¸ü¦¸¼Æ: 5

2021-1-1 14:05