First of all, its completely functional but the time it takes to complete is 10-20 seconds and will trigger numerous clipboard issues. I’m a complete amateur with VBA macros, but I managed to make it work somehow, if you make suggestions please assume I’m 5 years old.
The function of the macro is to match a current and a new article in a column and match it to equally named article in a different sheet. Then it has to create a table in a 3rd sheet and return values if they are different from each other. Right now it’s doing it through CopyPaste and I feel like I have hit the limit of my capabilities of blunt forcing this.
Sub CreateRebuidlistOptima()
Sheets("RebuildPrintOptima").DisplayPageBreaks = False
Application.ScreenUpdating = False
StartRow = 2 'Row to start on for printable rebuild sheet
'1. Clear printable rebuild sheet
Worksheets("RebuildPrintOptima").Range("A1:A500").EntireRow.Clear
Worksheets("RebuildPrintOptima").Cells.EntireRow.Hidden = False
Worksheets("RebuildPrintOptima").Cells.EntireRow.Hidden = False
'1. end
'2. Define the article nr for rebuild
Worksheets("RebuildPage").Select
CurrentArticle = Worksheets("RebuildPage").Cells(9, 4)
NewArticle = Worksheets("RebuildPage").Cells(11, 4)
Set FoundArticle = Worksheets("RebuildPage").Range("P3:P100").Find(What:=CurrentArticle, LookIn:=xlValues)
CurrentArticleRow = FoundArticle.Row
CurrentArticle = Worksheets("RebuildPage").Cells(CurrentArticleRow, 18)
Set FoundArticle = Worksheets("RebuildPage").Range("P3:P100").Find(What:=NewArticle, LookIn:=xlValues)
NewArticleRow = FoundArticle.Row
NewArticle = Worksheets("RebuildPage").Cells(NewArticleRow, 18)
'2. end
'3. Define Columns for chosen articles
Set FoundArticle = Worksheets("RebuildMatrixOptima").Range("H4:AZ4").Find(What:=CurrentArticle, LookIn:=xlValues)
CurrentArticleColumn = FoundArticle.Column
Set FoundArticle = Worksheets("RebuildMatrixOptima").Range("H4:AZ4").Find(What:=NewArticle, LookIn:=xlValues)
NewArticleColumn = FoundArticle.Column
'3. End
'4. Get header rebuild list
Worksheets("RebuildMatrixOptima").Range("A5:I5").Copy
Worksheets("RebuildPrintOptima").Cells(StartRow, 1).PasteSpecial (xlPasteAll)
Worksheets("RebuildPrintOptima").Cells(StartRow, 1).PasteSpecial (xlPasteColumnWidths)
Worksheets("RebuildMatrixOptima").Cells(5, CurrentArticleColumn).Copy
Worksheets("RebuildPrintOptima").Cells(StartRow, 10).PasteSpecial (xlPasteAll)
Worksheets("RebuildPrintOptima").Cells(StartRow, 10).PasteSpecial (xlPasteColumnWidths)
Application.CutCopyMode = False
Worksheets("RebuildMatrixOptima").Cells(5, NewArticleColumn).Copy
Worksheets("RebuildPrintOptima").Cells(StartRow, 11).PasteSpecial (xlPasteAll)
Worksheets("RebuildPrintOptima").Cells(StartRow, 11).PasteSpecial (xlPasteColumnWidths)
Application.CutCopyMode = False
'4. End
'5. Loop which rows to include
' i is the first row of the rebuild list to check
i = 6
Do Until i = 100
If Worksheets("RebuildMatrixOptima").Cells(i, 9) = "I" Then ' always show
CopyRow = 1
Else
If Worksheets("RebuildMatrixOptima").Cells(i, 9) = "N" Then ' never show
CopyRow = 0
Else
If Worksheets("RebuildMatrixOptima").Cells(i, CurrentArticleColumn) = Worksheets("RebuildMatrixOptima").Cells(i, NewArticleColumn) Then 'return value if different
CopyRow = 0
Else
CopyRow = 1
End If
End If
End If
If CopyRow = 1 Then
StartRow = StartRow + 1
Worksheets("RebuildMatrixOptima").Range("A" & i, "I" & i).Copy
Worksheets("RebuildPrintOptima").Cells(StartRow, 1).PasteSpecial (xlPasteAll)
Worksheets("RebuildMatrixOptima").Cells(i, CurrentArticleColumn).Copy
Worksheets("RebuildPrintOptima").Cells(StartRow, 10).PasteSpecial (xlPasteAll)
Worksheets("RebuildMatrixOptima").Cells(i, NewArticleColumn).Copy
Worksheets("RebuildPrintOptima").Cells(StartRow, 11).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
CheckNextRow = i + 1
If Worksheets("RebuildMatrixOptima").Cells(CheckNextRow, 1) = "" Then
i = 100
Else
i = i + 1
End If
Loop
'5. End
'6 Hide Unnecessary columns
Worksheets("RebuildPrintOptima").Range("A:A").EntireColumn.Hidden = True
Worksheets("RebuildPrintOptima").Range("B:B").EntireColumn.Hidden = True
Worksheets("RebuildPrintOptima").Range("D:D").EntireColumn.Hidden = True
Worksheets("RebuildPrintOptima").Range("E:E").EntireColumn.Hidden = True
Worksheets("RebuildPrintOptima").Range("I:I").EntireColumn.Hidden = True
'6 End
Worksheets("RebuildPrintOptima").Select
Application.ScreenUpdating = True
Sheets("RebuildPrintOptima").DisplayPageBreaks = True
End Sub`
Pretty much reached the end of my abilities
New contributor
Lennart Lemmens is a new contributor to this site. Take care in asking for clarification, commenting, and answering.
Check out our Code of Conduct.
5
Option Explicit
Sub CreateRebuidlistOptima()
Dim wsPrint As Worksheet, wsPage As Worksheet, wsMatrix As Worksheet
Dim CurrentArticle As String, NewArticle As String
Dim CurrentArticleColumn As Long, NewArticleColumn As Long
Dim rngFound As Range
Dim bCopyRow As Boolean, startrow As Long, i As Long
Dim t0 As Single: t0 = Timer
With ThisWorkbook
Set wsPrint = .Sheets("RebuildPrintOptima")
Set wsPage = .Sheets("RebuildPage")
Set wsMatrix = .Sheets("RebuildMatrixOptima")
End With
Application.ScreenUpdating = False
startrow = 2 'Row to start on for printable rebuild sheet
'1. Clear printable rebuild sheet
With wsPrint
.DisplayPageBreaks = False
.Range("A1:A500").EntireRow.Clear
.Cells.EntireRow.Hidden = False
End With
'1. end
'2. Define the article nr for rebuild
With wsPage
CurrentArticle = .Range("D9")
NewArticle = .Range("D11")
With .Range("P3:P100")
Set rngFound = .Find(What:=CurrentArticle, LookIn:=xlValues)
If rngFound Is Nothing Then
MsgBox CurrentArticle & " not found in P3:P100", vbCritical
Exit Sub
Else
CurrentArticle = rngFound.Offset(, 2) 'col 18 R
End If
Set rngFound = .Find(What:=NewArticle, LookIn:=xlValues)
If rngFound Is Nothing Then
MsgBox NewArticle & " not found in P3:100", vbCritical
Exit Sub
Else
NewArticle = rngFound.Offset(, 2) 'col 18 R
End If
End With
End With
'2. end
With wsMatrix
'3. Define Columns for chosen articles
With .Range("H4:AZ4")
Set rngFound = .Find(What:=CurrentArticle, LookIn:=xlValues)
If rngFound Is Nothing Then
MsgBox CurrentArticle & " not found in H4:AZ4", vbCritical
Exit Sub
Else
CurrentArticleColumn = rngFound.Column
End If
Set rngFound = .Find(What:=NewArticle, LookIn:=xlValues)
If rngFound Is Nothing Then
MsgBox NewArticle & " not found in H4:AZ4", vbCritical
Exit Sub
Else
NewArticleColumn = rngFound.Column
End If
End With
'3. End
'4. Get header rebuild list
.Cells(5, 1).Resize(1, 9).Copy wsPrint.Cells(startrow, 1)
.Cells(5, CurrentArticleColumn).Copy wsPrint.Cells(startrow, 10)
.Cells(5, NewArticleColumn).Copy wsPrint.Cells(startrow, 11)
'4. End
'5. Loop which rows to include
' i is the first row of the rebuild list to check
i = 6
Do Until i = 100 Or .Cells(i, 1) = ""
If .Cells(i, 9) = "I" Then ' always show
bCopyRow = True
Else
If .Cells(i, 9) = "N" Then ' never show
bCopyRow = False
Else
'return value if different
If .Cells(i, CurrentArticleColumn) = .Cells(i, NewArticleColumn) Then
bCopyRow = False
Else
bCopyRow = True
End If
End If
End If
If bCopyRow = True Then
startrow = startrow + 1
.Cells(i, 1).Resize(1, 9).Copy wsPrint.Cells(startrow, 1)
.Cells(i, CurrentArticleColumn).Copy wsPrint.Cells(startrow, 10)
.Cells(i, NewArticleColumn).Copy wsPrint.Cells(startrow, 11)
End If
i = i + 1
Loop
'5. End
End With
'6 Hide Unnecessary columns
With Worksheets("RebuildPrintOptima")
.Range("A:B,D:E,I:I").EntireColumn.Hidden = True
.DisplayPageBreaks = True
.Select
End With
'6 End
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Timer - t0, "0.0 secs"), vbInformation
End Sub