Dear all,

The following is the situation. I import a file into an excel sheet.
This file contains order information. What I want my code to do, is to
identify what kind of product(s) is/are ordered per order (and write
this down in a cell at the end of the row), and also to identify the
unique orders (an order can consists of more then just 1 orderline).
Then I want to copy only the lines marked as unique order to a second
sheet.

My code does this, except that it forgets to check the last row. My
file looks like this :
Intro(Sheet 1): contains the button that a person needs to press, this
will activate a dialogue window that instructs the user to browse the
folder to locate the file that needs to be imported.
Master sheet (sheet 2): in this sheet all information that is being
imported is placed here first, then 2 additional columns are added to
specify what kind of product(s) is in the order, and wether it is
unique order.
Unique orders (Sheet 3): All unique orders from Master sheet are
copied to this sheet (not all columns).

The problem is that the last row in Mastersheet is skipped by the
code, and thus not copied to the 3rd sheet either. Can any of you help
me, I have enclosed the code.

Gr,
Mariam



Option Explicit



Private Sub cmdCancel_Click()

Unload Me

End Sub

Private Sub cmdOK_Click()

Dim strFilePath As String
Dim strFileName As String
Dim strTATFile As String
' Variables for sorting out the correct orderlines
Dim lngRow As Long
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngFinalRow As Long ' End of data
Dim strOrderNumber As String
Dim strPreviousOrderNumber As String
Dim strProduct(1 To 5) As String
Dim intProduct(1 To 5) As Integer
Dim x As Integer
Dim strOmschrijving As String



On Error GoTo Foutje

strProduct(1) = "C8AV" 'Desktop
strProduct(2) = "C7AV" 'Desktop
strProduct(3) = "E6AV" 'Laptop
strProduct(4) = "94A" 'Monitor
strProduct(5) = "A2AV" 'Laptop

strTATFile = ActiveWorkbook.Name
strFilePath = txtPath.Text
Workbooks.Open strFilePath
strFileName = ActiveWorkbook.Name
Workbooks(strFileName).Sheets(1).Select

Cells.Select
Selection.Copy
Windows(strTATFile).Activate



Workbooks(strTATFile).Sheets("Master Sheet").Select
Cells.Select
ActiveSheet.Paste
Application.DisplayAlerts = False

Windows(strFileName).Close

Application.DisplayAlerts = True

Range("A1").Activate
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending,
Header:=True, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal


lngRow = 2
lngFirstRow = 2

Do Until Cells(lngRow, 7).Value = ""
strOrderNumber = Cells(lngRow, 7).Value
If strOrderNumber = strPreviousOrderNumber Then
' Same order, more then 1 orderline

' RAise ProductCounter - ProductTeller ophogen
For x = 1 To 5
If Cells(lngRow, 8).Value = strProduct(x) Then
intProduct(x) = intProduct(x) + 1
End If
Next x


Else
' New Order - Nieuwe order

lngFirstRow = lngLastRow + 1
lngLastRow = lngRow - 1
If lngFirstRow 1 Then
Cells(lngFirstRow, 31).Value = "*"
End If


If intProduct(1) + intProduct(2) + intProduct(3) +
intProduct(5) = 0 Then
'Remove - Verwijderen
For x = lngFirstRow To lngLastRow
'Cells(x, 7).Interior.Color = vbRed
'coloured columns are marked for deletion - test
purposes
If x 1 Then
Cells(x, 7).EntireRow.Clear
End If
Next x

Else
'Writing wether this is about a desktop, laptop, or a
combination of laptop/desktop.
If intProduct(1) + intProduct(2) 0 Then
strOmschrijving = "desktop"
If intProduct(3) + intProduct(5) 0 Then
strOmschrijving = "Desktop-Laptop"
End If
Else
If intProduct(3) + intProduct(5) 0 Then
strOmschrijving = "laptop"
End If
End If

For x = lngFirstRow To lngLastRow
If x 1 Then
Cells(x, 30).Value = strOmschrijving
End If
Next x
End If

'Empty ProductCounter - Leeggooien van Teller (van de
producten)
For x = 1 To 5
intProduct(x) = 0
Next x

'Filling up Product Counter - En daarna vullen van Teller
met deze regel

For x = 1 To 5
If Cells(lngRow, 8).Value = strProduct(x) Then
intProduct(x) = intProduct(x) + 1
End If
Next x


End If

strPreviousOrderNumber = strOrderNumber
lngRow = lngRow + 1
Loop
'lngFinalRow = lngRow - 1

lngFinalRow = lngRow
For x = lngFinalRow To 2 Step -1
If Cells(x, 7) = "" Then
Cells(x, 7).EntireRow.Delete Shift:=xlUp
End If
Next x

Cells(1, 30).Value = "Product"

WriteUniqueOrders lngFinalRow
Unload Me


'CreatePivotTable

Exit Sub

Foutje:
MsgBox "File could not be opened"

End Sub


Sub WriteUniqueOrders(lngFinalRow As Long)

Dim x As Integer


Sheets("Master Sheet").Select
Cells.Select
Selection.Copy
Sheets("Unique Orders").Select
Cells.Select
ActiveSheet.Paste
Cells(1, 1).Select

For x = lngFinalRow To 2 Step -1
If Cells(x, 31) = "" Then '30 veranderd naar 31
Cells(x, 31).EntireRow.Delete
End If
Next x

Columns("H:I").Delete Shift:=xlToLeft
Columns("AB:AB").Delete Shift:=xlToLeft

CreateNames

Sheets("Master sheet").Select
Cells(1, 1).Select




End Sub


Sub CreateNames()

Dim lngNumberOfRows As Long

'Label naam moet gedelete worden, foutmelding wordt gegenereerd
indien er geen
'label bestaat om te deleten. met deze error handling wordt deze
situatie opgevangen.
'De reden waarom het gedelete moet worden, is voor het geval deze
bestaat.
On Error Resume Next 'Bij foutdoorgaan met volgende regel.
ActiveWorkbook.Names("UniqueOrders").Delete
On Error GoTo 0 'Vanaf hier wel weer foutmeldingen


lngNumberOfRows = Sheets("Unique
Orders").Range("A1").CurrentRegion.Rows.Count

ActiveWorkbook.Names.Add Name:="UniqueOrders", RefersToR1C1:= _
"='Unique Orders'!R1C1:R" & lngNumberOfRows & "C27"
End Sub

Private Function GetFileToOpenName() As String

Dim BestandsNaam As String
Dim File_Dialoog As FileDialog
Dim Result As Long

Set File_Dialoog = Application.FileDialog(msoFileDialogOpen)
File_Dialoog.Filters.Clear
File_Dialoog.Filters.Add "Excelworksheet (*.xls)", "*.xls", 1
Result = File_Dialoog.Show()

If Result = -1 Then
GetFileToOpenName = File_Dialoog.SelectedItems.Item(1)
Else
GetFileToOpenName = ""
End If

End Function

Private Sub cmdOpen_Click()

txtPath.Text = GetFileToOpenName

End Sub

Dear readers,

Is any of you out there who can help me with the below ? I am
desperate, and in dire need of a solution.

Thanks in advance,
Mariam




(Mariam) wrote in message . com...
Dear all,

The following is the situation. I import a file into an excel sheet.
This file contains order information. What I want my code to do, is to
identify what kind of product(s) is/are ordered per order (and write
this down in a cell at the end of the row), and also to identify the
unique orders (an order can consists of more then just 1 orderline).
Then I want to copy only the lines marked as unique order to a second
sheet.

My code does this, except that it forgets to check the last row. My
file looks like this :
Intro(Sheet 1): contains the button that a person needs to press, this
will activate a dialogue window that instructs the user to browse the
folder to locate the file that needs to be imported.
Master sheet (sheet 2): in this sheet all information that is being
imported is placed here first, then 2 additional columns are added to
specify what kind of product(s) is in the order, and wether it is
unique order.
Unique orders (Sheet 3): All unique orders from Master sheet are
copied to this sheet (not all columns).

The problem is that the last row in Mastersheet is skipped by the
code, and thus not copied to the 3rd sheet either. Can any of you help
me, I have enclosed the code.

Gr,
Mariam



Option Explicit



Private Sub cmdCancel_Click()

Unload Me

End Sub

Private Sub cmdOK_Click()

Dim strFilePath As String
Dim strFileName As String
Dim strTATFile As String
' Variables for sorting out the correct orderlines
Dim lngRow As Long
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngFinalRow As Long ' End of data
Dim strOrderNumber As String
Dim strPreviousOrderNumber As String
Dim strProduct(1 To 5) As String
Dim intProduct(1 To 5) As Integer
Dim x As Integer
Dim strOmschrijving As String



On Error GoTo Foutje

strProduct(1) = "C8AV" 'Desktop
strProduct(2) = "C7AV" 'Desktop
strProduct(3) = "E6AV" 'Laptop
strProduct(4) = "94A" 'Monitor
strProduct(5) = "A2AV" 'Laptop

strTATFile = ActiveWorkbook.Name
strFilePath = txtPath.Text
Workbooks.Open strFilePath
strFileName = ActiveWorkbook.Name
Workbooks(strFileName).Sheets(1).Select

Cells.Select
Selection.Copy
Windows(strTATFile).Activate



Workbooks(strTATFile).Sheets("Master Sheet").Select
Cells.Select
ActiveSheet.Paste
Application.DisplayAlerts = False

Windows(strFileName).Close

Application.DisplayAlerts = True

Range("A1").Activate
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending,
Header:=True, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal


lngRow = 2
lngFirstRow = 2

Do Until Cells(lngRow, 7).Value = ""
strOrderNumber = Cells(lngRow, 7).Value
If strOrderNumber = strPreviousOrderNumber Then
' Same order, more then 1 orderline

' RAise ProductCounter - ProductTeller ophogen
For x = 1 To 5
If Cells(lngRow, 8).Value = strProduct(x) Then
intProduct(x) = intProduct(x) + 1
End If
Next x


Else
' New Order - Nieuwe order

lngFirstRow = lngLastRow + 1
lngLastRow = lngRow - 1
If lngFirstRow 1 Then
Cells(lngFirstRow, 31).Value = "*"
End If


If intProduct(1) + intProduct(2) + intProduct(3) +
intProduct(5) = 0 Then
'Remove - Verwijderen
For x = lngFirstRow To lngLastRow
'Cells(x, 7).Interior.Color = vbRed
'coloured columns are marked for deletion - test
purposes
If x 1 Then
Cells(x, 7).EntireRow.Clear
End If
Next x

Else
'Writing wether this is about a desktop, laptop, or a
combination of laptop/desktop.
If intProduct(1) + intProduct(2) 0 Then
strOmschrijving = "desktop"
If intProduct(3) + intProduct(5) 0 Then
strOmschrijving = "Desktop-Laptop"
End If
Else
If intProduct(3) + intProduct(5) 0 Then
strOmschrijving = "laptop"
End If
End If

For x = lngFirstRow To lngLastRow
If x 1 Then
Cells(x, 30).Value = strOmschrijving
End If
Next x
End If

'Empty ProductCounter - Leeggooien van Teller (van de
producten)
For x = 1 To 5
intProduct(x) = 0
Next x

'Filling up Product Counter - En daarna vullen van Teller
met deze regel

For x = 1 To 5
If Cells(lngRow, 8).Value = strProduct(x) Then
intProduct(x) = intProduct(x) + 1
End If
Next x


End If

strPreviousOrderNumber = strOrderNumber
lngRow = lngRow + 1
Loop
'lngFinalRow = lngRow - 1

lngFinalRow = lngRow
For x = lngFinalRow To 2 Step -1
If Cells(x, 7) = "" Then
Cells(x, 7).EntireRow.Delete Shift:=xlUp
End If
Next x

Cells(1, 30).Value = "Product"

WriteUniqueOrders lngFinalRow
Unload Me


'CreatePivotTable

Exit Sub

Foutje:
MsgBox "File could not be opened"

End Sub


Sub WriteUniqueOrders(lngFinalRow As Long)

Dim x As Integer


Sheets("Master Sheet").Select
Cells.Select
Selection.Copy
Sheets("Unique Orders").Select
Cells.Select
ActiveSheet.Paste
Cells(1, 1).Select

For x = lngFinalRow To 2 Step -1
If Cells(x, 31) = "" Then '30 veranderd naar 31
Cells(x, 31).EntireRow.Delete
End If
Next x

Columns("H:I").Delete Shift:=xlToLeft
Columns("AB:AB").Delete Shift:=xlToLeft

CreateNames

Sheets("Master sheet").Select
Cells(1, 1).Select




End Sub


Sub CreateNames()

Dim lngNumberOfRows As Long

'Label naam moet gedelete worden, foutmelding wordt gegenereerd
indien er geen
'label bestaat om te deleten. met deze error handling wordt deze
situatie opgevangen.
'De reden waarom het gedelete moet worden, is voor het geval deze
bestaat.
On Error Resume Next 'Bij foutdoorgaan met volgende regel.
ActiveWorkbook.Names("UniqueOrders").Delete
On Error GoTo 0 'Vanaf hier wel weer foutmeldingen


lngNumberOfRows = Sheets("Unique
Orders").Range("A1").CurrentRegion.Rows.Count

ActiveWorkbook.Names.Add Name:="UniqueOrders", RefersToR1C1:= _
"='Unique Orders'!R1C1:R" & lngNumberOfRows & "C27"
End Sub

Private Function GetFileToOpenName() As String

Dim BestandsNaam As String
Dim File_Dialoog As FileDialog
Dim Result As Long

Set File_Dialoog = Application.FileDialog(msoFileDialogOpen)
File_Dialoog.Filters.Clear
File_Dialoog.Filters.Add "Excelworksheet (*.xls)", "*.xls", 1
Result = File_Dialoog.Show()

If Result = -1 Then
GetFileToOpenName = File_Dialoog.SelectedItems.Item(1)
Else
GetFileToOpenName = ""
End If

End Function

Private Sub cmdOpen_Click()

txtPath.Text = GetFileToOpenName

End Sub