M
Mariam
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 column), 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
importaed is placed here first, then 2 additional columns are added to
specify what kind of product is in the order, and wether it is unique
or not
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
' Test of VerwijderLoop nodig is --- Origineel
'If intProduct(1) + intProduct(2) + intProduct(3) = 0 Or
intProduct(3) + intProduct(4) = 0 Then
'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
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
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 column), 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
importaed is placed here first, then 2 additional columns are added to
specify what kind of product is in the order, and wether it is unique
or not
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
' Test of VerwijderLoop nodig is --- Origineel
'If intProduct(1) + intProduct(2) + intProduct(3) = 0 Or
intProduct(3) + intProduct(4) = 0 Then
'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
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