Advertisement
bl00dt3ars

ZUTEIL

Aug 7th, 2022
1,544
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VBScript 10.25 KB | None | 0 0
  1. Sub ZUTEIL_()
  2.  
  3. Application.ScreenUpdating = False
  4.  
  5. Dim t As Single
  6. t = Timer
  7. Dim answer As VbMsgBoxResult
  8.     answer = MsgBox("Do you want to run ZUTEIL_ macro?", vbYesNo, "Run Macro")
  9.     If answer = vbYes Then
  10.  
  11.     Dim WS_Count As Integer
  12.     Dim i As Integer
  13.     Dim last_record As Integer
  14.     Dim art_num As String
  15.     Dim art_count As Integer
  16.     Dim active_rows As Integer
  17.     ActiveWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
  18.     WS_Count = ActiveWorkbook.Worksheets.Count
  19.    
  20.     Range("a1").Value = "Artnr"
  21.     Range("b1").Value = "LiefNr"
  22.     Range("c1").Value = "von_datum"
  23.     Range("d1").Value = "bis_datum"
  24.     Range("e1").Value = "Filiale"
  25.     Range("f1").Value = "Zuteilmenge"
  26.     Range("g1").Value = "Ve_Be_Faktor"
  27.     Range("h1").Value = "Send_Cd"
  28.     Range("i1").Value = "Aufteil_Cd"
  29.    
  30.     For i = 1 To WS_Count - 1
  31.    
  32.         ActiveWorkbook.Worksheets(i).Select
  33.         If Range("A2") = "" Then
  34.             Range("b2:p2").Select
  35.             Selection.AutoFilter
  36.             ActiveSheet.Range(Selection, Selection.End(xlDown)).AutoFilter Field:=5, Criteria1:="<>TOTAL"
  37.             ActiveSheet.Range(Selection, Selection.End(xlDown)).AutoFilter Field:=14, Criteria1:=">0"
  38.             Range("B3").Select
  39.             Range(Selection, Selection.End(xlDown)).Select
  40.             Application.CutCopyMode = False
  41.             Selection.Copy
  42.             ActiveWorkbook.Worksheets(WS_Count).Select
  43.             If Range("A2") = "" Then
  44.                 Range("A2").Select
  45.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  46.                 :=False, Transpose:=False
  47.             ElseIf Range("A3") = "" Then
  48.                 Range("A3").Select
  49.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  50.                 :=False, Transpose:=False
  51.             Else
  52.                 last_record = Range("A2").End(xlDown).Row + 1
  53.                 Cells(last_record, 1).Select
  54.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  55.                 :=False, Transpose:=False
  56.                 End If
  57.             ActiveWorkbook.Worksheets(i).Select
  58.             Range("D3").Select
  59.             Range(Selection, Selection.End(xlDown)).Select
  60.             Application.CutCopyMode = False
  61.             Selection.Copy
  62.             ActiveWorkbook.Worksheets(WS_Count).Select
  63.             If Range("E2") = "" Then
  64.                 Range("E2").Select
  65.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  66.                 :=False, Transpose:=False
  67.             ElseIf Range("E3") = "" Then
  68.                 Range("E3").Select
  69.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  70.                 :=False, Transpose:=False
  71.             Else
  72.                 last_record = Range("E2").End(xlDown).Row + 1
  73.                 Cells(last_record, 5).Select
  74.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  75.                 :=False, Transpose:=False
  76.                 End If
  77.             ActiveWorkbook.Worksheets(i).Select
  78.             Range("O3").Select
  79.             Range(Selection, Selection.End(xlDown)).Select
  80.             Application.CutCopyMode = False
  81.             Selection.Copy
  82.             ActiveWorkbook.Worksheets(WS_Count).Select
  83.             If Range("F2") = "" Then
  84.                 Range("F2").Select
  85.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  86.                 :=False, Transpose:=False
  87.             ElseIf Range("F3") = "" Then
  88.                 Range("F3").Select
  89.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  90.                 :=False, Transpose:=False
  91.             Else
  92.                 last_record = Range("F2").End(xlDown).Row + 1
  93.                 Cells(last_record, 6).Select
  94.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  95.                 :=False, Transpose:=False
  96.                 End If
  97.         Else
  98.             Dim cur_cols As Integer
  99.             cur_cols = Range("a5").End(xlToRight).Column
  100.             Range(Cells(7, 1), Cells(7, cur_cols)).Select
  101.             Selection.AutoFilter
  102.             ActiveSheet.Range(Selection, Selection.End(xlDown)).AutoFilter Field:=cur_cols, Criteria1:=">0"
  103.             art_num = ActiveWorkbook.Worksheets(i).Name
  104.             If WorksheetFunction.CountIf(Range(Cells(8, cur_cols), Cells(250, cur_cols)), ">0") > 1 Then
  105.                 Range("a8").Select
  106.                 art_count = Application.WorksheetFunction.Subtotal(3, Range(Selection, Selection.End(xlDown)))
  107.                 ActiveWorkbook.Worksheets(WS_Count).Select
  108.                 If Range("A2") = "" Then
  109.                     Range("A2", Cells(art_count + 1, 1)).Value = art_num
  110.                 ElseIf Range("A3") = "" Then
  111.                     Range("A3", Cells(art_count + 1, 1)).Value = art_num
  112.                 Else
  113.                     last_record = Range("A2").End(xlDown).Row + 1
  114.                     Range(Cells(last_record, 1), Cells(last_record + art_count - 1, 1)).Value = art_num
  115.                     End If
  116.                 ActiveWorkbook.Worksheets(i).Select
  117.                 Range("A8").Select
  118.                 Range(Selection, Selection.End(xlDown)).Select
  119.                 Application.CutCopyMode = False
  120.                 Selection.Copy
  121.                 ActiveWorkbook.Worksheets(WS_Count).Select
  122.                 If Range("E2") = "" Then
  123.                     Range("E2").Select
  124.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  125.                     :=False, Transpose:=False
  126.                 ElseIf Range("E3") = "" Then
  127.                     Range("E3").Select
  128.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  129.                     :=False, Transpose:=False
  130.                 Else
  131.                     last_record = Range("E2").End(xlDown).Row + 1
  132.                     Cells(last_record, 5).Select
  133.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  134.                     :=False, Transpose:=False
  135.                     End If
  136.                 ActiveWorkbook.Worksheets(i).Select
  137.                 Cells(8, cur_cols).Select
  138.                 Range(Selection, Selection.End(xlDown)).Select
  139.                 Application.CutCopyMode = False
  140.                 Selection.Copy
  141.                 ActiveWorkbook.Worksheets(WS_Count).Select
  142.                 If Range("F2") = "" Then
  143.                     Range("F2").Select
  144.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  145.                     :=False, Transpose:=False
  146.                 ElseIf Range("F3") = "" Then
  147.                     Range("F3").Select
  148.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  149.                     :=False, Transpose:=False
  150.                 Else
  151.                     last_record = Range("F2").End(xlDown).Row + 1
  152.                     Cells(last_record, 6).Select
  153.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  154.                     :=False, Transpose:=False
  155.                     End If
  156.             ElseIf WorksheetFunction.CountIf(Range(Cells(8, cur_cols), Cells(250, cur_cols)), ">0") = 1 Then
  157.                 art_count = 1
  158.                 ActiveWorkbook.Worksheets(WS_Count).Select
  159.                 If Range("A2") = "" Then
  160.                     Range("A2", Cells(art_count + 1, 1)).Value = art_num
  161.                 ElseIf Range("A3") = "" Then
  162.                     Range("A3", Cells(art_count + 1, 1)).Value = art_num
  163.                 Else
  164.                     last_record = Range("A2").End(xlDown).Row + 1
  165.                     Range(Cells(last_record, 1), Cells(last_record + art_count - 1, 1)).Value = art_num
  166.                     End If
  167.                 ActiveWorkbook.Worksheets(i).Select
  168.                 Range("A8").Select
  169.                 Selection.Copy
  170.                 ActiveWorkbook.Worksheets(WS_Count).Select
  171.                 If Range("E2") = "" Then
  172.                     Range("E2").Select
  173.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  174.                     :=False, Transpose:=False
  175.                 ElseIf Range("E3") = "" Then
  176.                     Range("E3").Select
  177.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  178.                     :=False, Transpose:=False
  179.                 Else
  180.                     last_record = Range("E2").End(xlDown).Row + 1
  181.                     Cells(last_record, 5).Select
  182.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  183.                     :=False, Transpose:=False
  184.                     End If
  185.                 ActiveWorkbook.Worksheets(i).Select
  186.                 Cells(8, cur_cols).Select
  187.                 Selection.Copy
  188.                 ActiveWorkbook.Worksheets(WS_Count).Select
  189.                 If Range("F2") = "" Then
  190.                     Range("F2").Select
  191.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  192.                     :=False, Transpose:=False
  193.                 ElseIf Range("F3") = "" Then
  194.                     Range("F3").Select
  195.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  196.                     :=False, Transpose:=False
  197.                 Else
  198.                     last_record = Range("F2").End(xlDown).Row + 1
  199.                     Cells(last_record, 6).Select
  200.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  201.                     :=False, Transpose:=False
  202.                     End If
  203.                 End If
  204.             End If
  205.     Next i
  206.    
  207.     Range("A2").Select
  208.     active_rows = Range(Selection, Selection.End(xlDown)).Count
  209.     Range("B2", Cells(active_rows + 1, 2)).Value = 699998
  210.     Range("H2", Cells(active_rows + 1, 8)).Value = "J"
  211.     Range("I2", Cells(active_rows + 1, 9)).Value = "K"
  212.     Range("A2:I2").Select
  213.     Range(Selection, Selection.End(xlDown)).Select
  214.     Selection.Copy
  215.     End If
  216.  
  217. MsgBox "The task is completed in " & Round(Timer - t, 0) & "s"
  218.  
  219. End Sub
  220.  
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement