PDA

View Full Version : Moving different rows data to one row based on criteria to optimise on printing



VISHAL120
05-07-2019, 11:11 PM
Hi ,

I need help on how we can automate this task through VBA as actually we are doing this manually and is very time consuming and many errors also are being made.

Thank in advance for any tips and guidance.

We have actually a visual planning which we have already generated through many calculations (was possible also with the forum help to automate it).

Refer to the attached file on sheet Actual_Visual_Planning. This result is obtain after all the calculation is done and is generated with the help of VBA as the initial calculation are not as such.

The visual planning are printed and given to all department to follow on which date what order is starting and also on which line number, etc.

The problem when we are printing for info the planning itself is with almost 1000 rows with 26 line of production and almost 8 -25 orders plan per production line.) this is taking a lot of pages like almost 20-25 pages sometime even more.

We have come up with a solution where we are copy and pasting the planned orders from the below row for the first row of the same Line Number and deleting all the orders plan below thus keeping only the data pasted in the single row.

Refer to the sheet Exp_Visual_Planning to have a better idea of what we are doing actually manually.

When pasting we are just moving the planned data same as the date it starting thus keeping them in the same column as it was initially on sheet Actual_Visual_Planning.

And same apply when the line number changes, we will paste to the first row of the concern line number.

So its just like moving up the planned data for sheet Actual_Visual_Planning up on the same column but on the first row for each production line.

This is taking a considerably amount of time for doing it as its being done manually and we have to copy paste for all the 26 lines like that taking into consideration different orders we have and also the risk of mistake we are making.

By so doing we have been able to print the visual plan in almost 6-8 pages instead of 20-25 pages.

I will be much grateful if I can get some guidance and tips on how I can automate the copy, paste and delete the below lines through vba please.

: pray2:: pray2::banghead::banghead:

大灰狼1976
05-08-2019, 01:15 AM
Hi VISHAL120!
Line Name B has overlapping parts.
Between ROW(29:30) and ROW(32:33), column CX.


--Okami

大灰狼1976
05-08-2019, 01:28 AM
If has no overlapping parts:

Sub test()
Dim r&, rng As Range, i&, cCnt&, rngBlk As Range
For i = 11 To Cells(Rows.Count, 1).End(3).Row Step 3
If Cells(i, 1) <> Cells(i - 2, 1) Then
r = i
Else
Set rng = Cells(i, 213).End(1)
If rng.MergeCells Then cCnt = rng.MergeArea.Columns.Count Else cCnt = 1
c = rng.Column
rng.Resize(2, cCnt).Copy Cells(r, c)
If rngBlk Is Nothing Then Set rngBlk = Rows(i).Resize(3) Else Set rngBlk = Union(rngBlk, Rows(i).Resize(3))
End If
Next i
rngBlk.Delete
End Sub

VISHAL120
05-08-2019, 01:54 AM
Hi ,

thanks for your kind help and support.
for the overlapping parts we just move it to the next free columns otherwise we just move it upwards and also as you see on the sheet Exp_Visual_Planning we place the borders manually so that it's easy to identify the orders in between.

I have testes the code i work well when there is no overlapping as you said. thank you a lot but can you just see to it for the borders in between the orders that are moving up and also in case there are over lapping to just move it to the next free column.

thanks you again for your kind support an quick help sir.

大灰狼1976
05-08-2019, 05:49 PM
Hi VISHAL120!

Sub test()
Dim r&, rng As Range, i&, cCnt&, rngBlk As Range
Application.ScreenUpdating = False
For i = 11 To Cells(Rows.Count, 1).End(3).Row Step 3
If Cells(i, 1) <> Cells(i - 2, 1) Then
r = i
Else
Set rng = Cells(i, 213).End(1)
If rng.MergeCells Then cCnt = rng.MergeArea.Columns.Count Else cCnt = 1
c = rng.Column
Do While Cells(r, c).MergeCells
c = c + 1
Loop
rng.Resize(2, cCnt).Copy Cells(r, c)
If rngBlk Is Nothing Then Set rngBlk = Rows(i).Resize(3) Else Set rngBlk = Union(rngBlk, Rows(i).Resize(3))
End If
Next i
rngBlk.Delete
Application.ScreenUpdating = True
End Sub

VISHAL120
05-08-2019, 10:31 PM
Hi Okami,

thank you so much works very well with the overlapping. can you please for a last one advise how we can place the borders same as the below example file attached.

thanks again for the kind help and time.

大灰狼1976
05-08-2019, 11:58 PM
like below:

Sub test001()
Dim r&, rng As Range, i&, cCnt&, rngBlk As Range
Application.ScreenUpdating = False
For i = 11 To Cells(Rows.Count, 1).End(3).Row Step 3
If Cells(i, 1) <> Cells(i - 2, 1) Then
r = i
If Cells(i, 83).MergeCells Then cCnt = Cells(i, 83).MergeArea.Columns.Count Else cCnt = 1
Call Bord(r, 83, cCnt)
Else
Set rng = Cells(i, 213).End(1)
If rng.MergeCells Then cCnt = rng.MergeArea.Columns.Count Else cCnt = 1
c = rng.Column
Do While Cells(r, c).MergeCells
c = c + 1
Loop
rng.Resize(2, cCnt).Copy Cells(r, c)
Call Bord(r, c, cCnt)
If rngBlk Is Nothing Then Set rngBlk = Rows(i).Resize(3) Else Set rngBlk = Union(rngBlk, Rows(i).Resize(3))
End If
Next i
rngBlk.Delete
Application.ScreenUpdating = True
End Sub

Sub Bord(r, c, cCnt)
Dim i&
For i = 7 To 10
With Cells(r, c).Resize(2, cCnt).Borders(i)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Next i
End Sub

VISHAL120
05-09-2019, 12:55 AM
Hi Okami,

thanks you a lot, yes same as such.

fantastic you made my day sir.:clap::clap:

大灰狼1976
05-09-2019, 01:51 AM
Hi VISHAL120!
You're welcome:beerchug:
In fact, it's best to process data when it's generated.

VISHAL120
05-09-2019, 09:13 PM
Hi Okami,

Thank you for the suggestion, indeed we wanted to do that but the code already when generating the visual plan is taking almost 25 secs + for that so that is why we break it in 2 parts .

大灰狼1976
05-09-2019, 09:24 PM
Hi VISHAL120!
Can you post the whole file here(with little data), Maybe I can make better suggestions.:)

VISHAL120
05-09-2019, 11:05 PM
Hi Okami,

sure and thanks for the kind help. let me remove some data from it and also seperate it from the main file and i will send it during the day.

VISHAL120
05-10-2019, 05:00 AM
Hi okami,

As requested here attached the file with part of the data. I am just sending the part which is concern with the visual planning report .


You will see on the file there are 5 sheets( some of the sheets has been added just for your info.

Sheet Customer_Color_Codes is where the customer colors are keep so as to place the color as per the customer color we have define.
Sheet Master_Visual is where we will have the data to start generating the visual planning report. This data is obtain from calculation which are done before.
Sheet VISUAL DISPLAY REPORT is the report which have already been generated.
Sheet LINEAR VISUAL PLAN this is the part that you have help me to be able to show the user the orders plan in one line and improve for the printing.


You will see I have place the code on buttons that I have place on the master_Visual.



The steps I am proceeding actually are as follows:
For better understanding please do run as explain below then you will see exactly the process.



Click on the button populate lines.
After it has duplicate the lines I need to add Number 1 at the end on the column G. this is because to keep the last row in odd number to help for line insertion in between the order reference which were duplicated otherwise it will insert line in between the order reference itself. Sheet Visual Planning format error shows how the error will be if the Number 1 is not place.
<<This one takes almost 57 secs to process.>>
Click on button Build Visual Display Report this will generate the visual same as sheet VISUAL DISPLAY REPORT. <<This one takes almost 25 secs to process.>>
After the Visual display report has been generated then click on the button Linear Visual Plan to have the last final results same as Sheet LINEAR VISUAL PLAN (the one that you have help). <<This one takes nearly 8-10 secs to process.>>


Thank you in advance if you can guide on speeding this part. Just to inform all these were done manual to get the final results which were taking days to do with all the mistakes and involving 2 people. Today we have been able to do it in let say may be 5 mins compare to days.
If I can still improve it then it good enough.

大灰狼1976
05-13-2019, 02:15 AM
Hi VISHAL120!
Please refer to the attachment. Maybe a little faster.

VISHAL120
05-13-2019, 04:41 AM
Hi Okami,
thank you very much i have try to go through the codes but found it very complex but still its quite faster compare to the previous code.

i will try to compile the code on the main planning and see what it give as result on the speed, am sure it will be very much better than the previous one.

once i finish i will revert back to you. thanks again for the kind help.

VISHAL120
05-14-2019, 07:38 AM
Hi Okami,
I have tested the code you have done it works very well and very quick too but i dont know why all of a sudden am having error to generate the report. Am attaching the file below for your understanding.
i have even run it with the break F8 and still could find the mistake if you can just give some idea on it.

大灰狼1976
05-14-2019, 09:03 PM
Hi VISHAL120!
The reason for the error is that there is no customer color of "ORC-AC" in sheets ("Customer_Color_Codes").
You can also set a "other" color, which is used for all items that do not exist in the list, Of course I need to modify the code.

VISHAL120
05-15-2019, 12:29 AM
Hi Okami,

thanks for the clarification and help.
one last help brother.
for the T-A-O-OF-VA-L or T-A-O-OF-N-L

which is done by this code :


If Left(.Value, 1) = "T" Then .Characters(Start:=1, Length:=1).Font.Color = IIf(arr(rw, 12) = "", -16776961, -11489280) ' T 'Use your method intact, only change worksheet function into vba.
If Mid(.Value, 3, 1) = "A" Then .Characters(Start:=3, Length:=1).Font.Color = IIf(arr(rw, 10) = "", -16776961, -11489280) ' A
If Mid(.Value, 5, 1) = "O" Then .Characters(Start:=5, Length:=1).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 7, 2) = "OF" Then .Characters(Start:=7, Length:=2).Font.Color = IIf(arr(rw, 25) = "", -16776961, -11489280) 'OF
If Mid(.Value, 9, 2) = "VA" Or Mid(.Value, 9, 1) = "N" Then .Characters(Start:=9, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 11, 1) = "L" Then .Characters(Start:=9, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O



I have added some code more so that but if you will run the code you will see the VA and L are not changing color based on the condition that are set for
If Mid(.Value, 5, 1) = "O" Then .Characters(Start:=5, Length:=1).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O

can you please help on this part please i have tried many times it remain the same it don't change the color on this part. which means if the O is red the VA and the L also shall be Red else Green.

And also on this part of the code where it takes the interior color of the cells:

For Each c In dTmp.keys
r = r + 3
arr1 = Split(dTmp(c), "+")
.Cells(r, 1).Resize(2, 2) = Split(c, ",")
.Cells(r, 1).Resize(2, 2).Interior.Color = arr1(0)
For i = 1 To UBound(arr1) Step 6

It shall also change the font color accordingly as it changes only the interior color and leaving the font color black for which in some lines the font is not visible where its darker. see row 15-16 . 18-19 for example the font for the lines number and name shall have been white.

Thank you in advance.

大灰狼1976
05-15-2019, 02:16 AM
because of Mid(.Value, 9, 2)="-", so you can change 9 into 10 and try it again.

VISHAL120
05-15-2019, 03:32 AM
Hi Okami,

I have finally figured the part for the T-A-O-OF-VA-L or T-A-O-OF-N-L color change which are as below:

If Left(.Value, 1) = "T" Then .Characters(Start:=1, Length:=1).Font.Color = IIf(arr(rw, 12) = "", -16776961, -11489280) ' T 'Use your method intact, only change worksheet function into vba.
If Mid(.Value, 3, 1) = "A" Then .Characters(Start:=3, Length:=1).Font.Color = IIf(arr(rw, 10) = "", -16776961, -11489280) ' A
If Mid(.Value, 5, 1) = "O" Then .Characters(Start:=5, Length:=1).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 7, 2) = "OF" Then .Characters(Start:=7, Length:=2).Font.Color = IIf(arr(rw, 25) = "", -16776961, -11489280) 'OF
If Mid(.Value, 10, 2) = "VA" Then .Characters(Start:=10, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 10, 1) = "N" Then .Characters(Start:=10, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 13, 1) = "L" Then .Characters(Start:=13, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 12, 1) = "L" Then .Characters(Start:=12, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 13, 1) = "N" Then .Characters(Start:=13, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 12, 1) = "N" Then .Characters(Start:=12, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O

can you guide me on the part below please:

And also on this part of the code where it takes the interior color of the cells:

For Each c In dTmp.keys
r = r + 3
arr1 = Split(dTmp(c), "+")
.Cells(r, 1).Resize(2, 2) = Split(c, ",")
.Cells(r, 1).Resize(2, 2).Interior.Color = arr1(0)
For i = 1 To UBound(arr1) Step 6
It shall also change the font color accordingly as it changes only the interior color and leaving the font color black for which in some lines the font is not visible where its darker. see row 15-16 . 18-19 for example the font for the lines number and name shall have been white.

大灰狼1976
05-15-2019, 04:37 AM
Hi VISHAL120!
The cells.interior.color is extracted at the following step:

If Not dTmp.exists(s) Then 'Assigning all useful data to the dictionary ITEM through a string connection
dTmp(s) = .Cells(i + 10, 1).Interior.Color
End If

If you need to copy the complete format, it is more convenient to copy the format.
The whole code is as follows:

Private Sub CommandButton1_Click()
Dim dClr As Object, dDate As Object, dTmp As Object, arr, arr1, i&, s$, s1$, s2$, st&, en&, c, r&, j&, rw&
Dim start_Time#, End_Time#
Set dClr = CreateObject("scripting.dictionary")
Set dDate = CreateObject("scripting.dictionary")
Set dTmp = CreateObject("scripting.dictionary")
start_Time = Timer
Application.StatusBar = " Karina Automate Calculation Started : For Visual Planning Report Generate ...."
arr = Sheets("Customer_Color_Codes").[a1].CurrentRegion
For i = 1 To UBound(arr)
dClr(arr(i, 1)) = arr(i, 2)
Next i
With Sheets("Master_Visual")
arr = .[ce10:hd10].Value
For i = 1 To UBound(arr, 2)
dDate(arr(1, i)) = i 'use dictionary instead of "FIND" for date lookup. dDate(date) = column number
Next i
arr = .Range("a11:cd" & .Cells(Rows.Count, 1).End(3).Row) 'Master_Visual columnA to columnCD data assigned to arr
For i = 1 To UBound(arr)
st = dDate(arr(i, 60)) + 2: en = dDate(arr(i, 61)) + 2 'The reason for "+2" is that the date starts in column C of resultsheet.
If st > 2 And en > 2 Then 'If both start and end dates are found
s = arr(i, 1) & "," & arr(i, 2) 'The variable s is the key of the dictionary and its content is Chaine Name & "," & Chaine No.
s1 = "CUST:-" & arr(i, 3) & "-REF: " & arr(i, 7) & "-TDG: " & arr(i, 48) & "-LOADED LINE" & arr(i, 43) & " - ORDERED: " 'Use your method intact, only change worksheet function into vba.
s1 = s1 & arr(i, 8) & " - FAB: " & Format(arr(i, 11), "DD-MMM") & "- CUT DATE: " & Format(arr(i, 27), "DD-MMM") & "-SEW: "
s1 = s1 & Format(arr(i, 60), "DD-MMM") & " TO " & Format(arr(i, 61), "DD-MMM") & " - DEL: " & Format(arr(i, 70), "DD-MMM")
If arr(i, 11) <> "" Then s2 = "T-" Else s2 = "" 'Use your method intact, only change worksheet function into vba.
If arr(i, 9) <> "" Then s2 = s2 & "A-"
If arr(i, 18) <> "" Then s2 = s2 & "O-"
If arr(i, 24) <> "" Then s2 = s2 & "OF-"
If arr(i, 32) = "VA" Then s2 = s2 & "VA-" Else s2 = s2 & "N-"
If arr(i, 33) = "L" Then s2 = s2 & "L" Else s2 = s2 & "N"
If Not dTmp.exists(s) Then 'Assigning all useful data to the dictionary ITEM through a string connection
dTmp(s) = .Cells(i + 10, 1).Interior.Color
End If
dTmp(s) = dTmp(s) & "+" & dClr(arr(i, 3)) & "+" & s1 & "+" & s2 & "+" & st & "+" & en & "+" & i
End If
Next i
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Display Report").Delete
On Error GoTo 0
With Sheets("Format")
.Visible = True
.Copy after:=Sheets(Sheets.Count)
.Visible = 2
End With
ActiveSheet.Name = "Display Report"
With Sheets("Display Report")
.[c2:eb2] = dDate.keys 'Export all dates to the worksheet Display Report
.Rows(3).Resize(3).Copy .Rows(3).Resize(3 * dTmp.Count) 'Generate the required data row format
For Each c In dTmp.keys
r = r + 3
arr1 = Split(dTmp(c), "+")
.Cells(r, 1).Resize(2, 2) = Split(c, ",")
For i = 1 To UBound(arr1) Step 6
st = arr1(i + 3): en = arr1(i + 4)
Do Until .Cells(r, st) = "" And .Cells(r, st).MergeCells = False
st = st + 1
en = en + 1
Loop
.Cells(r, st) = arr1(i + 1)
.Cells(r, st).Interior.Color = arr1(i)
.Cells(r, st).WrapText = True
With .Cells(r + 1, st)
.Value = arr1(i + 2)
.Interior.Color = arr1(i)
.NumberFormat = ""
rw = arr1(i + 5)
If Left(.Value, 1) = "T" Then .Characters(Start:=1, Length:=1).Font.Color = IIf(arr(rw, 12) = "", -16776961, -11489280) ' T 'Use your method intact, only change worksheet function into vba.
If Mid(.Value, 3, 1) = "A" Then .Characters(Start:=3, Length:=1).Font.Color = IIf(arr(rw, 10) = "", -16776961, -11489280) ' A
If Mid(.Value, 5, 1) = "O" Then .Characters(Start:=5, Length:=1).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 7, 2) = "OF" Then .Characters(Start:=7, Length:=2).Font.Color = IIf(arr(rw, 25) = "", -16776961, -11489280) 'OF
If Mid(.Value, 10, 2) = "VA" Then .Characters(Start:=10, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 10, 1) = "N" Then .Characters(Start:=10, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 13, 1) = "L" Then .Characters(Start:=13, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 12, 1) = "L" Then .Characters(Start:=12, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 13, 1) = "N" Then .Characters(Start:=13, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 12, 1) = "N" Then .Characters(Start:=12, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
End With
.Range(.Cells(r, st), .Cells(r, en)).Merge
.Range(.Cells(r + 1, st), .Cells(r + 1, en)).Merge
For j = 7 To 10
With .Range(.Cells(r, st), .Cells(r, en)).Resize(2).Borders(j)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Next j
Next i
Sheets("Master_Visual").Cells(arr1(i - 1) + 10, 1).Resize(, 2).Copy
.Cells(r, 1).Resize(2, 2).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Next c
End With
End_Time = Timer
Application.StatusBar = "Karina Automated Planning For Visual Planning Report Completed In " & Format(End_Time - start_Time, "0.000") & "secs"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

VISHAL120
05-17-2019, 01:38 AM
Hi Okami,

sorry for the late reply .

Thank you a lot it works very well and very quick too.
appreciate your kind help and u thank you a lot on behalf of my team Brother.

by the way brother can give me some tips on how and when we can use scripting dictionary as i see the code has done all the the calculation quick enough whereas i was doing it in 3 steps. As i have a lot of project am working on our own department and am taking much more time to do it and are rather complex operation and we need to automate a lot of process for analysis as these are taking lot of time and also lot of manpower. thanks in advance.

:clap::clap::clap:

大灰狼1976
05-17-2019, 04:20 AM
Hi VISHAL120!
You're welcome.:)
Dictionary is not very efficient in any case, so we should choose the processing method according to the actual situation.
But most of the problems can be solved efficiently through array + dictionary.
The dictionary is actually very simple in function and use:
d(key)=item
item=d(key)
d.exists(x) to determine whether x exists.