API tools faq
paste
Advertisement
bl00dt3ars

ZUTEIL

bl00dt3ars
Aug 7th, 2022
1,544
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VBScript 10.25 KB | None | 0 0
raw download clone embed print report
  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
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!