Need help about Macro code

KenndovinA · Jun 4, 2018

Hello there,
have one issue, and hope that someone from this forum can help me...

When I export data's from some application, it gives me excel file with alot of information.
Former IT employee have made Macro, who served to sort the data.
Few days ago, application is updated, and probably changed some of the export data, and Macro does not sort data as before.
So can someone check out code and see what should be changed, so after his run sort data as before?
So the old Macro code is:

Sub MacroZaFlightListImproved()

'
' Makro za Flight List za Air Serbia
'
' Shortcut: CTRL + j
'

MsgBox "FlightList Procedure" & vbNewLine & "with UPPERCASE upgrade" & vbNewLine & "Version 5.1 (14.06)"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Data Validation
Dim RightNow As Date
Dim objDate As Date
'Set Objective Date
objDate = CDate("2/10/2035")
Application.ScreenUpdating = False
RightNow = Functions.InternetDate()
If RightNow > objDate Then
MsgBox ("Run-time error '400':" & vbNewLine & vbNewLine & "Data Validation Error"), , "Error Encountered"
GoTo EndMac:
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Columns("A:A").Select
Selection.Insert Shift:=xlToLeft, CopyOrigin:=xlFormatFromLeftOrAbove

Dim R As Integer
Dim i As Long
Dim Row As Long
Dim V As Variant
Dim Rng As Range
Dim Col As Variant

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'
' Sredjivanje Mr, Ms, Mrs, Chd, Inf
'

Set Rng = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("C"))
For i = 2 To Rng.Rows.Count Step 1
Application.StatusBar = "Processing Row" & R
If Cells(i, "D") Like "Mr" Or Cells(i, "D") Like "Ms" Or Cells(i, "D") Like "Mrs" Then
Cells(i, "A").Value = "1" + Cells(i, "E").Value + "/" + Cells(i, "F").Value
Else
If Cells(i, "D") Like "Chd" Then
Cells(i, "A").Value = "1" + Cells(i, "E").Value + "/" + Cells(i, "F").Value + " CHLD " + Cells(i, "G").Value
Else
If Cells(i, "D") Like "Inf" Then
Cells(i, "A").Value = ".R/INFT " + Cells(i, "E").Value + "/" + Cells(i, "F").Value + " " + Cells(i, "G").Value
End If
End If
End If
Next i

Cells("2", "A").Value = Cells(2, "C").Value + " " + Cells(5, "C").Value
Range("B2").Select
Selection.Cut
Range("B52").Select
Selection.Cut

Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("F:X").Select
Selection.Delete Shift:=xlToLeft

Columns("A:A").EntireColumn.AutoFit

EndMacro:

' Loop to cycle through each cell in the specified range.
For Each x In Range("A1:A200")
' Change the text in the range to uppercase letters.
x.Value = UCase(x.Value)
Next

'
' Razmaci po broju prijava
'
Col = C
Set Rng = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("C"))
For R = Rng.Rows.Count To 2 Step -1
Application.StatusBar = "Processing Row" & R
If Rng.Cells(R, Col) <> 0 Then
If Rng.Cells(R - 1, Col) <> Rng.Cells(R, Col) Then
'Rng.Rows(R).EntireRow.Delete
'MsgBox "Trenutni Br. Prijave" & Rng.Cells(R, Col) & " Predhodni Br. Prijave" & Rng.Cells(R - 1, Col)
Rng.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
End If
Next R

Application.StatusBar = "Macro by Marko. Version 2016"

EndMac:
End Sub

Also, in attachment you can find non fixed and some old fixed file.

View attachment non fixed data.xls

View attachment old fixed data.xls

Thanx in advance! :israel:

p45cal · Jun 5, 2018

Try running this code while the new exported data is in the active sheet - you might be lucky.
It adds a new sheet and leaves the original data sheet untouched:

Code:

Sub blah()
Dim TopLeftCell As Range, myResults()
Set TopLeftCell = ActiveSheet.Cells.Find("Reservation No", LookIn:=xlFormulas, lookat:=xlWhole, MatchCase:=False, searchformat:=False)
If Not TopLeftCell Is Nothing Then
  Set myrng = Intersect(TopLeftCell.Resize(999).EntireRow, TopLeftCell.CurrentRegion)
  HeaderCells = myrng.Rows(1)
  ResNoColumn = 1
  TitleColumn = Application.Match("Title", HeaderCells, 0)
  SurnameColumn = Application.Match("Passenger Surname", HeaderCells, 0)
  NameColumn = Application.Match("Passenger Name", HeaderCells, 0)
  DobColumn = Application.Match("Birthday", HeaderCells, 0)
  'mySourceValues = myRng.Offset(-1).Resize(, Application.Max(TitleColumn, SurnameColum, nNameColumn, DOBColumn)) 'excludes summary row at botton.
  mySourceValues = myrng.Offset(-1).Resize(myrng.Rows.Count + 1, Application.Max(TitleColumn, SurnameColum, nNameColumn, DobColumn)).Value
  ReDim myResults(1 To UBound(mySourceValues), 1 To 2)
  For i = 1 To UBound(mySourceValues)
    myResults(i, 1) = mySourceValues(i, ResNoColumn)
    Select Case Trim(mySourceValues(i, TitleColumn))
      Case "Mr", "Mrs", "Ms"
        myResults(i, 2) = "1" & mySourceValues(i, SurnameColumn) & "/" & mySourceValues(i, NameColumn)
      Case "Chd"
        myResults(i, 2) = "1" & mySourceValues(i, SurnameColumn) & "/" & mySourceValues(i, NameColumn) & " CHLD " & mySourceValues(i, DobColumn)
      Case "Inf"
        myResults(i, 2) = ".R/INFT " & mySourceValues(i, SurnameColumn) & "/" & mySourceValues(i, NameColumn) & " " & mySourceValues(i, DobColumn)
    End Select
  Next i
End If
With Sheets.Add(after:=Sheets(Sheets.Count))
  .Cells(1).Resize(UBound(mySourceValues), 2).Value = myResults
  .UsedRange.Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(1), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  .Range("B1").Cut Destination:=.Range("C1")
  .Columns("A:B").Delete
  .UsedRange.RemoveSubtotal
  .Columns(1).AutoFit
End With
End Sub

If not, come back.

Need help about Macro code

KenndovinA

New member

p45cal

Super Moderator