ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] VBA ¶ñ¼gªí®æ¤Î¥t¦s·sÀÉ

¥»©«³Ì«á¥Ñ n7822123 ©ó 2021-1-1 13:54 ½s¿è

¦^´_ 9# lovenice831

DATA ªº¸ê®Æ·|¼W¥[¦Ó¨C¼W¥[¤@­Ó§Ú«K»Ý­n¦bREPORT ªí¤¤¶ñ¼g¹ïªº¸ê®Æ¡A
¦A§âREPORT ¥t¦s·sÀɤW¶Ç¦^¤½¥q¨t²Î¡A¦ÓREPORT ¬O¥ÎReference No:¨Ó¬ö¿ý¤Î©R¦W¡A
·|§_¦³»yªk¥i¥H¦bREPORT ­¶¤¤Â²¿ï Reference No:¡A«K¯à±qDATE ¤¤¦Û°Ê§ä¥X¹ïÀ³¸êÅã¥Ü¦bREPORT ¤¤?
§Ú¦bºô¤W§äªº¦h¬O¥Î©ó¦P¤@¤À­¶¤Îªí®æ³£¬O³æ¤@¹ïÀ³ªº¨Ò¤l¡A³o¥÷ªí®æªº½T¬O³Â·Ð¤F¨Ç¡A¥ýÁÂÁ§AªºÀ°¦£¡AÁÂÁÂ

§Ú°µ¤F­Ó ¼u¥Xªí³æ ¥Î ListBox Åý§A¿ï¡A¦ý¬O°µ¤Fªí³æ¡A¥u¶Kµ{¦¡´N¨S·N¸q¤F!

§A»Ý­n¤U¸ü§Úªºªþ¥ó¤~¯à¬Ý¨ì¨º­Óªí³æ¡A¦pªG§AÁÙ¬O¤£¯à¤U¸üªþ¥ó¡A§Ú¥u¯à¥Î Inputbox ¦C¥X¨ÓÅý§A¿ï¤F.......

·Ç¤jªººÃ´b¡A§Ú¤]¬O¦³ªº¡A¨º¨ÇCheckBox §Ú³£¨S¥h§ï³á¡A³£¬O­ì¥»ªº­È

¦³»Ý­n¡A¦A´£¨Ñ§PÂ_³W«hÅýVBA¥h¶ñ¡AÀɮצp¤U


test Receiving Data 2021-0101.rar (73.79 KB)
µ{¦¡¬O¨Ì»Ý¨D¼gªº¡A»Ý¨Dªí¹F¤£²M·¡
©ÎªÌ¨S¦³¤W¶Çªþ¥ó¡A·R²ö¯à§U

TOP

¦^´_ 11# n7822123

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

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


test Receiving Data 2021-0101(NEW).rar (69.7 KB)
µ{¦¡¬O¨Ì»Ý¨D¼gªº¡A»Ý¨Dªí¹F¤£²M·¡
©ÎªÌ¨S¦³¤W¶Çªþ¥ó¡A·R²ö¯à§U

TOP

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


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

TOP

¦^´_ 12# n7822123


    ÁÂÁÂ

TOP

§Ú¸ÕµÛ¥Î 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)

TOP

¦^´_ 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
µ{¦¡¬O¨Ì»Ý¨D¼gªº¡A»Ý¨Dªí¹F¤£²M·¡
©ÎªÌ¨S¦³¤W¶Çªþ¥ó¡A·R²ö¯à§U

TOP

¥»©«³Ì«á¥Ñ n7822123 ©ó 2021-1-5 01:56 ½s¿è

¦^´_ 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)
µ{¦¡¬O¨Ì»Ý¨D¼gªº¡A»Ý¨Dªí¹F¤£²M·¡
©ÎªÌ¨S¦³¤W¶Çªþ¥ó¡A·R²ö¯à§U

TOP

¥»©«³Ì«á¥Ñ n7822123 ©ó 2021-1-5 03:06 ½s¿è

¦^´_ 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)
µ{¦¡¬O¨Ì»Ý¨D¼gªº¡A»Ý¨Dªí¹F¤£²M·¡
©ÎªÌ¨S¦³¤W¶Çªþ¥ó¡A·R²ö¯à§U

TOP

¦^´_ 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)
µ{¦¡¬O¨Ì»Ý¨D¼gªº¡A»Ý¨Dªí¹F¤£²M·¡
©ÎªÌ¨S¦³¤W¶Çªþ¥ó¡A·R²ö¯à§U

TOP

¦^´_ 19# n7822123


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

TOP

        ÀR«ä¦Û¦b : §g¤l¦p¤ô¡AÀH¤è´N¶ê¡AµL³B¤£¦Û¦b¡C
ªð¦^¦Cªí ¤W¤@¥DÃD