Add, remove and sort

[Mann750]

Hi,

I have a few queries that I need help on and they all need to be applied to a set of data that changes every month.

I am able to download a delivery schedule from another source into Excel with a number of variables that need to be sorted into a more efficient way for variance analysis. Some of the cells are merged together but they are not always merged in a consistant manner. Also, I need to add the contract numbers to the list instead of having it displayed seperately. It will be easier to understand what I mean if I could attach my file but basically I would like this:

Contract 01/001
 
Delivery Date   Product  Sales  Person
 
Contract 02/001
 
Delivery Date   Product  Sales  Person

to become this:

Contract  Delivery Date  Product  Sales  Person
01/001    
02/001

I hope this makes sense and I would greatly appreciate any help.

Many thanks!

 

[Mann750]

Wow that's great hiker95! Just what I needed, thanks! I'm still trying to get my head around the coding because its not the approach I was thinking of taking but if it works then I can't argue )

I was wondering if you could help me with the query I had about my loop not stopping once it reached the last "Total" (see below). Do I need to put a break in after the last "Total" in the actual spreadsheet or is there something I can code in?

Thanks again for the help

Thanks VBACO, really appreciate it )

I've made a bit of progress with adding the contract numbers but I am having difficulty with stopping the loop...any ideas?

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
        Cells.Select
    With Selection
        .WrapText = False
        .MergeCells = False
    End With
    Selection.ColumnWidth = 8.43
    Selection.RowHeight = 12.75
    Range("A1").Select
 
Dim finddel As Range, finddel1 As Range, findtot As Range
 
    Set finddel = Range("B1:B55").Cells
    Range("B1").Select
 
    Set finddel1 = finddel.Find(what:="Delivery Date", after:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole)
 
    Do Until finddel1 Is Nothing
    ' This keeps running by going back to the beginning of column B and starting the process again
 
        Set findtot = finddel.Find(what:="Total", after:=finddel1, LookIn:=xlValues, LookAt:=xlWhole)
            finddel1.Offset(-3, 1).Select
            Selection.Copy
            Range(finddel1.Offset(2, -1), findtot.Offset(-1, -1)).PasteSpecial xlPasteValues
            findtot.Select
 
        Set finddel1 = finddel.Find(what:="Delivery Date", after:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole)
 
    Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

 

[hiker95]

Mann750,

Wow that's great hiker95! Just what I needed, thanks! I'm still trying to get my head around the coding because its not the approach I was thinking of taking but if it works then I can't argue )

You are very welcome.

Glad I could help.

Thanks for the feedback.

I was wondering if you could help me with the query I had about my loop not stopping once it reached the last "Total" (see below).

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


You could try (see below in BOLD):

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
        Cells.Select
    With Selection
        .WrapText = False
        .MergeCells = False
    End With
    Selection.ColumnWidth = 8.43
    Selection.RowHeight = 12.75
    Range("A1").Select
 
Dim finddel As Range, finddel1 As Range, findtot As Range
Dim LR As Long
 
    LR = Cells(Rows.Count, "B").End(xlUp).Row
    Set finddel = Range("B1:B" & LR).Cells
    Range("B1").Select

 

[hiker95]

Mann750,


This latest macro is a lot faster (same screenshots as above).


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub ReorgDataV2()
' hiker95, 08/19/2011
' http://www.mrexcel.com/forum/showthread.php?t=572682
Dim wC As Worksheet, wF As Worksheet
Dim LR As Long, LC As Long, LC2 As Long, a As Long, SR As Long, ER As Long, NR As Long
Dim Area As Range, rng As Range
Application.ScreenUpdating = False
Set wC = Worksheets("Customer Delivery Schedule")
If Not Evaluate("ISREF(Finished!A1)") Then Worksheets.Add(After:=wC).Name = "Finished"
Set wF = Worksheets("Finished")
wF.UsedRange.Clear
wC.UsedRange.Copy wF.Range("A1")
wF.Columns(1).Delete
With wF.UsedRange
  .WrapText = False
  .Orientation = 0
  .AddIndent = False
  .ShrinkToFit = False
  .ReadingOrder = xlContext
  .MergeCells = False
  .Font.Size = 9
  .Font.Bold = False
End With
On Error Resume Next
wF.Range("B1", wF.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
LR = wF.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
LC = wF.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column + 5
wF.Rows(1).Insert
For a = LR To 2 Step -1
  If wF.Cells(a, 1) = "Total" Then wF.Rows(a).Offset(1).Insert
Next a
For Each Area In wF.Range("B1", wF.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    SR = .Row
    ER = SR + .Rows.Count - 1
    On Error Resume Next
    wF.Range(wF.Cells(SR + 3, 1), wF.Cells(ER - 1, LC)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
    On Error GoTo 0
  End With
Next Area
LR = wF.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
wF.Range(Cells(1, 16), Cells(LR, LC)).Clear
LC2 = wF.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
wF.Cells(2, LC2 + 2).Resize(, 16) = [{"Contract","Delivery Date","Product Quantity","Product Type","Sales Order No.","Person","Product Quantity","Product Type","Product Quantity","Product Type","Product","Code","Outlet","Ship To","Status","System"}]
For Each Area In wF.Range("B1", wF.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    SR = .Row
    ER = SR + .Rows.Count - 1
    NR = wF.Cells(wF.Rows.Count, LC2 + 2).End(xlUp).Offset(1).Row
    wF.Range("B" & SR).Copy wF.Cells(NR, LC2 + 2).Resize(ER - 1 - SR - 2)
    wF.Range(wF.Cells(SR + 3, 1), wF.Cells(ER - 1, LC2)).Copy wF.Cells(NR, LC2 + 3)
  End With
Next Area
Set rng = wF.Range(Cells(1, 1), Cells(LR, LC2))
rng.Columns.Delete
LR = wF.Cells(Rows.Count, 2).End(xlUp).Row
LC = wF.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
With wF.Range("B3:B" & LR)
  .Font.Name = "Arial"
  .Font.FontStyle = "Regular"
  .Font.Size = 9
  With .Borders(xlEdgeLeft)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = 24
  End With
  With .Borders(xlEdgeTop)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = 24
  End With
  With .Borders(xlEdgeBottom)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = 24
  End With
  With .Borders(xlEdgeRight)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = 24
  End With
  With .Borders(xlInsideHorizontal)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = 24
  End With
End With
wF.Range(wF.Cells(3, 2), wF.Cells(LR, LC)).HorizontalAlignment = xlCenter
With wF.Range("B2:Q2")
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  .Font.Name = "Arial"
  .Font.FontStyle = "Bold"
  .Font.Size = 9
  .Font.ColorIndex = 2
  .Interior.ColorIndex = 47
End With
wF.UsedRange.Columns.AutoFit
wF.Activate
Application.ScreenUpdating = True
End Sub

Then run the ReorgDataV2 macro.

 

[Mann750]

hiker95! You are great! Many thanks for your help, I have managed to amend your code to fit my spreadsheets and it works perfectly D

 

[hiker95]

Mann750,

You are very welcome, again.

Glad I could help.

Thanks for the feedback.

Come back anytime.

 

[Mann750]

Hi hiker95 and all others,

I have another query that carries on from this one but wasn't sure if I should put it in another thread.

Now that I have my macro working to sort the data into the desired format I need to find variances between each of the individual contracts. In the past I have used sumproduct and it has worked fine but with the level of information that I am looking at now it is running really slowly and I would need to seperate sumproduct formulations for each of the different variables. For example:

Contract 01/001 - I would like to see if there are any changes to the delivery dates, the product quantities, product type etc between the current downloaded information and the information processed a month before.

The end product should be some kind of summary stating which variables have been changed for which month/year of delivery for each contract.

I have thought about creating a macro that seperates the table of information into seperate sheets dependent on contract number and then comparing the information but because of the number of contracts (100+) I don't know if it would be feasible to create so many sheets in one workbook.

Any help would be appreciated.

Many thanks!

 

[hiker95]

Mann750,

This does sound very different and more complicated.

I would suggest that you create a completely different New Post.

Supply screenshots of before and after worksheets. And, supply detailed instructions.

You can send me a Private Message with a link to your New Post, and I will examine your request.