API tools faq
paste
Advertisement
Guest User

s

a guest
Aug 19th, 2019
206
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 16.32 KB | None | 0 0
raw download clone embed print report
  1. Function LastRow(sh As Worksheet)
  2.     On Error Resume Next
  3.     LastRow = sh.Cells.Find(What:="*", _
  4.                             After:=sh.Range("A1"), _
  5.                             LookAt:=xlPart, _
  6.                             LookIn:=xlFormulas, _
  7.                             SearchOrder:=xlByRows, _
  8.                             SearchDirection:=xlPrevious, _
  9.                             MatchCase:=False).Row
  10.    
  11.     On Error GoTo 0
  12. End Function
  13.  
  14.  
  15.  
  16.  
  17.  
  18. Sub przesuniecia()
  19.  
  20.  
  21.  
  22. ' przesuniecia Makro
  23.  
  24.  Dim Start As Single
  25. Dim Koniec As Single
  26. Start = Timer
  27. Dim lark As Long
  28. Dim lexport As Long
  29. Dim klucz As String
  30. Dim nazwa As String
  31. Dim partia As String
  32. Dim indeks As String
  33. Dim skład As String
  34. Dim sprzedaz As String
  35. Dim i As Long
  36. Dim j As Long
  37. Dim ruch As String
  38. Dim zam As String
  39. Dim wierszk As Long
  40. Dim ilosc As Integer
  41. Dim czyznalazlo As Boolean
  42. Dim czyznalazlo2 As Boolean
  43. Dim pom As Long
  44. Dim pom2 As Long
  45. Dim bylo As String
  46. Dim odbmat As String
  47. Dim pktroz As String
  48.  
  49. Dim jest As String
  50. Dim dzientyg As Integer
  51. Dim dataspr As Date
  52. dzientyg = Weekday(Date)
  53. If dzientyg = 2 Then
  54. dataspr = Date - 3
  55. Else
  56. dataspr = Date - 1
  57. End If
  58.  
  59. czyznalazlo = False
  60. ilosc = 1000
  61. Windows("export.xlsm").Activate
  62. Worksheets("export").Activate
  63. lexport = LastRow(Worksheets("export")) 'zlicza ilosc ruchow
  64.  
  65. Windows("KOMUNALNE.xlsm").Activate
  66.  lark = Sheets.Count ' zlicza ilosc zakladek w komunalnym
  67.  
  68.  
  69. Windows("export.xlsm").Activate
  70. Worksheets("export").Activate
  71.       Range("R1").Select
  72.     ActiveCell.FormulaR1C1 = "Odbiorca"
  73.     Range("R2").Select
  74.     ActiveCell.FormulaR1C1 = _
  75.          "=IFERROR(IF(RC[-16]=""601"",VLOOKUP(CONCATENATE(RC[-17],RC[-5]),dane!R2C45:R46000C46,2,0),""""),""nie znalazło sprzedanego asortymentu"")"
  76.  
  77.     Range("R2").Select
  78.     Selection.AutoFill Destination:=Range("R2:R" & lexport), Type:=xlFillDefault
  79.  
  80.  
  81. Range("P2").Select
  82.     ActiveCell.FormulaR1C1 = _
  83.         "=IFERROR(VLOOKUP(LEFT(RC[-15],7),slownik!R1C1:R200C2,2,0), "" nie znalazło zakładki"") "
  84.   Range("P2").Select
  85.     Selection.AutoFill Destination:=Range("P2:P" & lexport), Type:=xlFillDefault
  86.  
  87.  
  88.  
  89.  
  90.  Columns("P:P").Select
  91.     Selection.NumberFormat = "@"
  92.    
  93.    
  94. For i = 2 To lexport Step 1 ' leci pętla po ruchach
  95. Windows("export.xlsm").Activate
  96. Worksheets("export").Activate
  97. klucz = Worksheets("export").Cells(i, 16)
  98. sprzedaz = Worksheets("export").Cells(i, 18)
  99. partia = Worksheets("export").Cells(i, 13)
  100. odbmat = Worksheets("export").Cells(i, 12)
  101. pktroz = Worksheets("export").Cells(i, 14)
  102. skład = Worksheets("export").Cells(i, 3)
  103. jest = skład
  104. ruch = Worksheets("export").Cells(i, 2)
  105. indeks = Worksheets("export").Cells(i, 1)
  106. ilosc = Worksheets("export").Cells(i, 9)
  107.  
  108.     For j = 1 To lark Step 1   ' szuka pojedynczego ruchu w pliku komuanlnym
  109.    Windows("KOMUNALNE.xlsm").Activate
  110.     czyznalazlo = False
  111.         czyznalazlo2 = False
  112.       nazwa = Worksheets(j).Name
  113.     If (nazwa = klucz) Then    'wchodzi do zakladki z tym ruchem
  114. czyznalazlo2 = True
  115.     Worksheets(j).Activate
  116.    
  117. wierszk = LastRow(Worksheets(j))
  118.  
  119.  
  120. '   RUCH 311
  121. '   RUCH 413
  122. '   RUCH 314
  123. '   RUCH 313
  124. '   RUCH 315
  125. '   RUCH 316
  126. '   RUCH 305
  127.  
  128.  
  129.     If ruch = "314" Or ruch = "413" Or ruch = "313" Or ruch = "315" Or ruch = "311" Or ruch = "316" Or ruch = "305" Or ruch = "301" Then    ' sprawdza czy to ruch 413 314 313 315 305
  130.                        
  131. For k = 30 To wierszk Step 1 ' leci po wierszach w konkretnej zakładce i szuka partii
  132.                          
  133.                     If Worksheets(j).Cells(k, 1).Value = "x" Then
  134.                     k = wierszk
  135.                     Else
  136.                    
  137.                    
  138.                        
  139.                            
  140.                            
  141.                                
  142.                                
  143.                                 If partia = Worksheets(j).Cells(k, 7) Then
  144. czyznalazlo = True
  145. If ilosc = 1 Or ilosc = 0 Then    ' sprawdza czy ruch jest z 1 , 0  czy -1
  146.  
  147. Worksheets(j).Cells(k, 7).Activate
  148. bylo = Worksheets(j).Cells(k, 6).Value
  149. Worksheets(j).Cells(k, 6).Value = skład
  150. If Left(Worksheets(j).Cells(k, 4).Value, 2) <> "g-" Then
  151.  
  152.  
  153. If Left(Worksheets(j).Cells(k, 1).Value, 14) <> indeks Then
  154. Worksheets(j).Cells(k, 1).Activate
  155. MsgBox "Kopiuje wiersz do bazy. Nie zgadza się indeks dla sprzetu: " & klucz & " dla partii " & partia
  156. Windows("export.xlsm").Activate
  157.      Worksheets("export").Activate
  158.    Rows(i).Select
  159.       Selection.Copy
  160.  
  161. Worksheets("niejasne").Activate
  162.    
  163.  
  164.      Rows(2).Select
  165.     Selection.Insert Shift:=xlDown
  166.  
  167.  
  168.  
  169.  
  170. End If
  171.  
  172.  
  173. Else
  174.  
  175. If Left(Worksheets(j).Cells(k, 3).Value, 14) <> indeks Then
  176. Worksheets(j).Cells(k, 3).Activate
  177. MsgBox "Kopiuje wiersz do bazy. Nie zgadza się indeks dla sprzetu: " & klucz & " dla partii " & partia
  178. Windows("export.xlsm").Activate
  179.      Worksheets("export").Activate
  180.    Rows(i).Select
  181.       Selection.Copy
  182.  
  183. Worksheets("niejasne").Activate
  184.    
  185.  
  186.      Rows(2).Select
  187.     Selection.Insert Shift:=xlDown
  188.  
  189.  
  190. End If
  191.  
  192.  
  193. End If
  194.  
  195.  
  196.  
  197. If InStr(1, Worksheets(j).Cells(k, 5).Value, "FPS", vbTextCompare) > 0 And bylo <> jest Then
  198. Worksheets(j).Cells(k, 13).Value = dataspr
  199. End If ' koniec ifa do daty przesunięcie
  200.  
  201.  
  202.  
  203.  
  204. End If ' koniec Ifa dla ilosci ruchu "1 "
  205.  
  206.                         Exit For
  207.     End If  ' koniec IFa jesli znajdzie partie
  208.    End If ' koniec dla elsa jesli jesli nie ma x
  209.  
  210. Next ' koniec pętli dla konkrretnej zakładki
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218. If czyznalazlo = False Then
  219. MsgBox "Coś poszło nie tak ! Kopiuje wiersz do bazy. Nie znalazło partii dla partii: " & partia & " indeks: " & indeks & " sprzęt: " & klucz
  220.  
  221. Windows("export.xlsm").Activate
  222.      Worksheets("export").Activate
  223.    Rows(i).Select
  224.       Selection.Copy
  225.  
  226. Worksheets("niejasne").Activate
  227.    
  228.  
  229.      Rows(2).Select
  230.     Selection.Insert Shift:=xlDown
  231.  
  232.  
  233.  
  234. End If
  235.  
  236.   ' jesli nie znajdzie ruchu 413 to:
  237.  
  238. '   RUCH 261
  239. '   RUCH 261
  240. '   RUCH 261
  241. '   RUCH 261
  242. '   RUCH 261
  243.  
  244.   ElseIf ruch = "261" Then
  245.  
  246.   For k = 30 To wierszk Step 1 ' leci po wierszach w konkretnej zakładce i szuka partii
  247. If Worksheets(j).Cells(k, 1).Value = "x" Then
  248.                     k = wierszk
  249.                     Else
  250.                                                    
  251.                                
  252.                                
  253.                                
  254.                                
  255.                                 If partia = Worksheets(j).Cells(k, 7) Then
  256.            
  257.            
  258.            
  259. czyznalazlo = True
  260.                                
  261.  
  262. If Left(Worksheets(j).Cells(k, 4).Value, 2) <> "g-" Then
  263.  
  264.  
  265.  
  266. Worksheets(j).Cells(k, 1).Select
  267.     With Selection.Font
  268.         .Color = -16776961
  269.         .TintAndShade = 0
  270.     End With
  271.    
  272.     End If ' koniec ifa dla <> g-
  273.    
  274.    
  275.    
  276.     End If
  277.  
  278.                        
  279.    
  280.     End If  ' koniec IFa jesli znajdzie partie
  281.    
  282.  
  283. Next ' koniec pętli
  284.  
  285.  
  286.  
  287.  
  288.  
  289.   If czyznalazlo = False Then
  290. MsgBox "Coś poszło nie tak ! Kopiuje wiersz do bazy. Zapewne dana maszyna jest już sprzedana. Sprawdź rekordy sprzedane. " & vbCrLf & "Nie znalazło partii: " & partia & "sprzet: " & klucz
  291.  
  292.  
  293. Windows("export.xlsm").Activate
  294.      Worksheets("export").Activate
  295.    Rows(i).Select
  296.       Selection.Copy
  297.  
  298. Worksheets("niejasne").Activate
  299.    
  300.  
  301.      Rows(2).Select
  302.     Selection.Insert Shift:=xlDown
  303.  
  304.  
  305.  
  306. End If
  307.  
  308.  
  309.  
  310.  
  311.   ' elseif
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  '  MsgBox " nie jest to ruch 413 314 313 315 216"
  324.  
  325.  
  326.  'ruch 601
  327.  'ruch 601
  328.  'ruch 601
  329.  'ruch 601
  330.  
  331.  
  332.   ElseIf ruch = "601" Or ruch = "551" Then
  333.  
  334.   For k = 30 To wierszk Step 1 ' leci po wierszach w konkretnej zakładce i szuka partii
  335. If Worksheets(j).Cells(k, 1).Value = "x" Then
  336.                 pom2 = k + 1
  337.                     k = wierszk
  338.                
  339.                     Else
  340.                                                    
  341.                                
  342.                                
  343.                                
  344.                                
  345.                                 If partia = Worksheets(j).Cells(k, 7) Then
  346.            
  347.            
  348.            
  349. czyznalazlo = True
  350.                                 pom = k
  351.                                
  352.  
  353. Worksheets(j).Cells(k, 9).Value = 0
  354.     Worksheets(j).Cells(k, 10).Value = 0
  355.     Worksheets(j).Cells(k, 6).Value = skład
  356.       zam = Worksheets(j).Cells(k, 8).Value
  357.      Worksheets(j).Cells(k, 14).Value = dataspr
  358.      
  359.        Worksheets(j).Cells(k, 15).Value = sprzedaz
  360.      
  361.      
  362.      Worksheets(j).Cells(k, 7).Select
  363.       With Selection.Font
  364.         .Color = -16776961
  365.         .TintAndShade = 0
  366.     End With
  367.      
  368.       With Selection.Interior
  369.         .Pattern = xlSolid
  370.         .PatternColorIndex = xlAutomatic
  371.         .Color = 255
  372.         .TintAndShade = 0
  373.         .PatternTintAndShade = 0
  374.     End With
  375.      Worksheets(j).Cells(k, 9).Activate
  376.      MsgBox "Zamówienie: " & zam & vbCrLf & " Sprzedaż do: " & sprzedaz
  377.      
  378.      
  379.      Rows(k).Select
  380.       Selection.Cut
  381.      
  382.      
  383.        
  384.     End If ' koniec IFa jesli znajdzie partie
  385.  
  386.                        
  387.    
  388.     End If
  389.    
  390.  
  391. Next ' koniec pętli
  392.  
  393.      Rows(pom2).Select
  394.     Selection.Insert Shift:=xlDown
  395.     Rows(pom2 - 1).Select
  396.     Selection.EntireRow.Hidden = True
  397.  
  398.  
  399.  
  400.   If czyznalazlo = False Then
  401. MsgBox "Coś poszło nie tak ! kopiuje wiersz do bazy. Zapewne dana maszyna jest już sprzedana. Sprawdź rekordy sprzedane. Nie znalazło partii dla ruchu: " & partia & "sprzęt: " & klucz
  402. Windows("export.xlsm").Activate
  403.      Worksheets("export").Activate
  404.    Rows(i).Select
  405.       Selection.Copy
  406.  
  407. Worksheets("niejasne").Activate
  408.    
  409.  
  410.      Rows(2).Select
  411.     Selection.Insert Shift:=xlDown
  412.  
  413.  
  414.  
  415. End If
  416.  
  417.  
  418.  
  419.  
  420.   ' elseif
  421.  
  422.  '  MsgBox " nie jest to ruch 413 314 313 315"
  423. ' koniec ruchu 601
  424. ' koniec ruchu 601
  425. ' koniec ruchu 601
  426. ' koniec ruchu 601
  427. ' koniec ruchu 601
  428. 'ruch 101
  429. 'ruch 101
  430. 'ruch 101
  431. 'ruch 101
  432. 'ruch 101
  433. 'ruch 101
  434.  
  435.  ElseIf ruch = "101" Or ruch = "531" Or ruch = "521" Then
  436.  
  437.   For k = 30 To wierszk Step 1 ' leci po wierszach w konkretnej zakładce i szuka partii
  438. If Worksheets(j).Cells(k, 1).Value = "x" Then
  439.                     k = wierszk
  440.                
  441.                     Else
  442.                                                    
  443.                                
  444.                                
  445.                                
  446.                                
  447.                                 If Worksheets(j).Cells(k, 10) <> "1" Then
  448.  
  449.                                 pom = k
  450.                                 Worksheets(j).Cells(k, 10).Activate
  451.                                 MsgBox "Ostatni wiersz niemagazynowy to: " & pom
  452.                                 Exit For
  453.                                
  454.                                 End If
  455.      
  456.        
  457.   ' koniec IFa jesli znajdzie partie
  458.  
  459.                        
  460.    
  461.     End If
  462.    
  463.  
  464. Next ' koniec pętli
  465.  
  466.  
  467.  Dim wsMsgBox As Object
  468.  
  469.     Set wsMsgBox = CreateObject("WScript.Shell")
  470.  
  471.     Dim mbResult As Integer
  472.  
  473.  
  474.  
  475.  
  476.  
  477.     'wyświetlamy okienko określając jego parametry
  478.    Worksheets(j).Cells(k, 10).Activate
  479.  
  480. mbResult = wsMsgBox.Popup("Ruch 101! " & vbCrLf & " Sprzęt: " & klucz & vbCrLf & " partia: " & partia & " indeks: " & indeks & vbCrLf & " Nic nie klikaj ! Znajdź wpierw numer wiersza, gdzie mam wstawić ruch 101, a nastepnie kliknij OK, by wprowadzić numer." & vbCrLf & " Kliknij Anuluj,by nie wstawiać ruchu 101.", _
  481.                 iTime, "Ruch 101!", 1)
  482.  
  483.  
  484.  
  485.  
  486.     Select Case mbResult
  487.  
  488.        Case 2
  489.  
  490.    
  491.         MsgBox "Nigdzie nie wstawiam ruchu 101. Kopiuje wiersz do bazy."
  492.     Windows("export.xlsm").Activate
  493.      Worksheets("export").Activate
  494.    Rows(i).Select
  495.       Selection.Copy
  496.  
  497. Worksheets("niejasne").Activate
  498.    
  499.  
  500.      Rows(2).Select
  501.     Selection.Insert Shift:=xlDown
  502.  
  503.  
  504.  
  505.  
  506.        Case 1
  507.  
  508.     Dim StrName As Integer 'deklarujemy zmienną imię
  509. StrName = InputBox("Wprowadź numer wiersza, gdzie mam dodać ruch 101 (sprzęt, partia, indeks)") & klucz & " " & partia & "indeks  " & indeks 'wprowadzamy wartość dla naszej zmiennej z okna InputBox
  510.  
  511.  
  512.  
  513.  
  514.  
  515.  
  516. MsgBox ("Wprowadzam ruch 101 w wierszu:  " & StrName & vbCrLf & "Miłego dnia!") 'prezentujemy komunikat
  517.  
  518.  
  519.  
  520. Worksheets(j).Cells(StrName, 9).Value = ""
  521.     Worksheets(j).Cells(StrName, 10).Value = 1
  522.     Worksheets(j).Cells(StrName, 6).Value = skład
  523.    
  524.  
  525.      
  526.      If indeks = Left(Worksheets(j).Cells(StrName, 3).Value, 14) Then
  527.      
  528.      Worksheets(j).Cells(StrName, 4).Value = "g-" & dataspr
  529.      
  530.      Worksheets(j).Cells(StrName, 1).Select
  531. With Selection.Font
  532. .Color = vbBlack 'kolor
  533. End With
  534.  
  535.      
  536.      
  537.     End If
  538.        
  539.  Worksheets(j).Cells(StrName, 7).Value = partia
  540.    Worksheets(j).Cells(StrName, 7).Select
  541. With Selection.Font
  542. .Color = vbBlack 'kolor
  543. End With
  544.  zam = Worksheets(j).Cells(StrName, 8).Value
  545.      Worksheets(j).Cells(StrName, 11).Value = dataspr
  546.       Worksheets(j).Cells(StrName, 12).Value = Year(dataspr)
  547.      
  548.      
  549.    
  550.    If (StrName <> pom) Then
  551.      
  552.      Rows(StrName).Select
  553.       Selection.Cut
  554.  
  555.      Rows(pom).Select
  556.     Selection.Insert Shift:=xlDown
  557.     End If
  558.    
  559.     If (StrName >= pom) Then ' zle zaznaczalo obszar do sortowania
  560.    
  561.       Worksheets(j).Cells(pom, 5).FormulaR1C1 = _
  562.         "=VLOOKUP(TEXT(R[0]C[1],0),'\\192.168.15.25\Analizy\RÓŻNE\Ad_stan_mag\SkladC.xls'!id,2,FALSE)"
  563.  
  564.   MsgBox "ostatni wiersz do sortowania to : " & pom
  565.      Rows("30:" & pom).Select
  566.     ActiveWorkbook.Worksheets(j).sort.SortFields.Clear
  567.     ActiveWorkbook.Worksheets(j).sort.SortFields.Add Key:=Range( _
  568.         "G30:G" & pom), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  569.         xlSortNormal
  570.     With ActiveWorkbook.Worksheets(j).sort
  571.         .SetRange Range("A30:AJ" & pom)
  572.         .Header = xlGuess
  573.         .MatchCase = False
  574.         .Orientation = xlTopToBottom
  575.         .SortMethod = xlPinYin
  576.         .Apply
  577.     End With
  578.    
  579.  Else ' jkesli numer wiersza wstawionego byl mniejszy od ostatniego z 1 to wowczaas zakres ost -1
  580.  
  581.  
  582.       Worksheets(j).Cells(pom - 1, 5).FormulaR1C1 = _
  583.         "=VLOOKUP(TEXT(R[0]C[1],0),'\\192.168.15.25\Analizy\RÓŻNE\Ad_stan_mag\SkladC.xls'!id,2,FALSE)"
  584.  
  585.   MsgBox "ostatni wiersz do sortowania to : " & pom - 1
  586.      Rows("30:" & pom - 1).Select
  587.     ActiveWorkbook.Worksheets(j).sort.SortFields.Clear
  588.     ActiveWorkbook.Worksheets(j).sort.SortFields.Add Key:=Range( _
  589.         "G30:G" & pom - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  590.         xlSortNormal
  591.     With ActiveWorkbook.Worksheets(j).sort
  592.         .SetRange Range("A30:AJ" & pom - 1)
  593.         .Header = xlGuess
  594.         .MatchCase = False
  595.         .Orientation = xlTopToBottom
  596.         .SortMethod = xlPinYin
  597.         .Apply
  598.     End With
  599.  
  600.  End If
  601.  
  602.  
  603.  
  604.  
  605.   End Select
  606.  
  607.  
  608.  
  609.   Else   ' gdy nie obsluzy danego ruchu kopiuje do niejasnych, nie ma zdefiniowanego takiego ruchu
  610.  MsgBox " nie mam w bazie ruchu " & ruch & " dla partii " & partia & " dla sprzętu " & klucz & vbCrLf & "Kopiuje zatem ruch do bazy"
  611.   Windows("export.xlsm").Activate
  612.      Worksheets("export").Activate
  613.    Rows(i).Select
  614.       Selection.Copy
  615.  
  616. Worksheets("niejasne").Activate
  617.    
  618.  
  619.      Rows(2).Select
  620.     Selection.Insert Shift:=xlDown
  621.  
  622.  
  623.  
  624.   End If ' koniec spraewdzania jaki to numer ruchu
  625.  
  626.     ' KONIEC RUCHU 413
  627.    ' KONIEC RUCHU 413
  628.    ' KONIEC RUCHU 413
  629.  
  630.     Exit For   'wyjscie z pętli jesli znajdzie zakładke o podanym asortymencie, po co ma gonic do konca
  631.  
  632.     End If ' koniec Ifa dla danej zakładki czy zakladka = PUV4000
  633.    
  634.     Next ' przewin zakladke w komunalnym do przodu
  635.    If czyznalazlo2 = False Then
  636. MsgBox "Coś poszło nie tak ! Nie znalazło zakładki: " & klucz & " partia " & partia & "indeks" & indeks & vbCrLf & "nie mam w bazie ruchu " & ruch & " dla partii " & partia & " dla sprzętu " & klucz & vbCrLf & "Kopiuje zatem ruch do bazy"
  637.   Windows("export.xlsm").Activate
  638.      Worksheets("export").Activate
  639.    Rows(i).Select
  640.       Selection.Copy
  641.  
  642. Worksheets("niejasne").Activate
  643.    
  644.  
  645.      Rows(2).Select
  646.     Selection.Insert Shift:=xlDown
  647.  
  648.   End If
  649.  
  650.  
  651.  
  652.  
  653.  
  654.     Next  ' przewin do kolejnego ruchu z exportu SAP
  655.    
  656.    
  657.    
  658.    
  659.    
  660.      Koniec = Timer
  661.     MsgBox "Czas wykonywania programu: " & Format(Koniec - Start, "0.00") & " s"
  662. End Sub
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!