Sub Button3_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = True
Dim filespec As Variant
Dim Input1 As String
Dim FirstFile As Workbook
Dim filespec1 As Variant
Dim Input2 As String
Dim SecondFile As Workbook
Dim Result As Workbook
Dim strChar As String
'Prompt user to select fileA
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", _
Title:="Please Open Summary file", _
MultiSelect:=False)
If filespec = False Then
GoTo Finish1
Else
End If
'Open selected workbookA
Workbooks.Open (filespec)
Input1 = ActiveWorkbook.Name
Set FirstFile = ActiveWorkbook
With FirstFile
.SaveAs Filename:="InputA.xls"
End With
'Prompt user to select fileB
filespec1 = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", _
Title:="Please Open Summary file", _
MultiSelect:=False)
If filespec1 = False Then
GoTo Finish1
Else
End If
'Open selected workbookB
Workbooks.Open (filespec1)
Input2 = ActiveWorkbook.Name
Set SecondFile = ActiveWorkbook
With SecondFile
.SaveAs Filename:="InputB.xls"
End With
Set Result = Workbooks.Add
With Result
.SaveAs Filename:="Output.xls"
End With
'Setting of first row
Range("A1").Select
ActiveCell.FormulaR1C1 = "Material"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Level-1"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Material Description"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Item"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Qty per"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Rev.Lvl"
Range("G1").Select
ActiveCell.FormulaR1C1 = "ROHS"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Reference"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Qual.Mafr."
Workbooks("InputA.xls").Worksheets("Sheet0").Range("B2").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("A2")
Workbooks("InputA.xls").Worksheets("Sheet0").Range("D2").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("C2")
Workbooks("Output.xls").Worksheets("Sheet1").Range("F2").Value = _
Mid(Workbooks("InputA.xls").Worksheets("Sheet0").[G2], 2, 1)
Dim wsInput As Worksheet, wsOutput As Worksheet, LastRow As Long, C As Range, D As Range, A As Range, B As Range, V As Range, Z As Range, i As Long, Where As Range
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
Set wsOutput = Workbooks("Output.xls").Worksheets("Sheet1")
Set Ws2 = Workbooks("InputA.xls").Worksheets("Sheet0")
LastRow = wsInput.Cells(wsInput.Rows.Count, "E").End(xlUp).Row
'Error starts from here
With wsInput
wsInput.Range("G3:G" & LastRow).AutoFilter Field:=1, Criteria1:=""
wsInput.Range("G3:G" & LastRow).SpecialCells(xlCellTypeVisible).Delete
wsInput.ShowAllData
Rows("3:" & LastRow).Select
wsInput.Sort.SortFields.Clear
wsInput.Sort.SortFields.Add Key _
:=Range("E3:E" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
End With
With wsInput.Sort
.SetRange Range("E3:E" & LastRow)
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim SearchValue As String, AddValue As String
With wsInput ' Always select your worksheet name
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Counter = 0
AddValue = ""
SearchValue = ""
For p = LastRow To 3 Step -1
SearchValue = .Range("C" & p).Value
'Check for duplicates
If SearchValue <> "" Then
If Application.WorksheetFunction.CountIf(.Range("C3:C" & LastRow), SearchValue) > 1 Then
For n = p To 3 Step -1
If .Range("C" & n).Value = SearchValue Then
If AddValue = "" Then
AddValue = .Range("E" & n).Value
Else
'Concatenate ColumnE and above value
AddValue = .Range("E" & n).Value & "," & AddValue
'Delete row
.Rows(n).EntireRow.Delete
Counter = Counter + 1
End If
End If
Next n
.Range("E" & p - Counter).Value = AddValue
AddValue = ""
SearchValue = ""
Counter = 0
End If
End If
Next p
'delete blank cells from inputB
LastRow = wsInput.Cells(wsInput.Rows.Count, "i").End(xlUp).Row
For i = LastRow To 2 Step -1
If wsInput.Cells(i, "F").Value = "" Then
wsInput.Rows(i).Delete
End If
Next
'copy columns F and G to I from inputB to output
'Copying data from InputB
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each C In .Range("F3:F" & LastRow)
wsOutput.Cells(C.Row, "I").Value = C & "" & " " & C.Offset(0, 1)
Next C
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each D In .Range("E3:E" & LastRow)
wsOutput.Cells(D.Row, "H").Value = D & ""
Next D
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each A In .Range("G3:E" & LastRow)
wsOutput.Cells(A.Row, "G").Value = "01"
Next A
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each V In .Range("D3:D" & LastRow)
wsOutput.Cells(V.Row, "E").Value = V & ""
Next V
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each Z In .Range("A3:A" & LastRow)
wsOutput.Cells(Z.Row, "D").Value = Z & ""
Next Z
End With
Dim y As Range, m As Range
With Ws2
'Copying Data from InputA
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each y In .Range("D3:D" & LastRow)
wsOutput.Cells(y.Row, "C").Value = y & Null
Next y
End With
With Ws2
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each m In .Range("B3:B" & LastRow)
wsOutput.Cells(m.Row, "B").Value = m & Null
Next m
End With
With Ws2
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For Each B In .Range("F3:F" & LastRow)
wsOutput.Cells(B.Row, "F").Value = Left(Workbooks("InputA.xls").Worksheets("Sheet0").Cells(B.Row, "G").Value, 1)
Next B
End With
wsOutput.Cells.HorizontalAlignment = xlLeft
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'Create header
Application.PrintCommunication = False
With ws.PageSetup
' .LeftHeaderPicture.Filename = "C:\Users\Public\Pictures\Sample Pictures\Desert.jpg"
.CenterHeader = wsOutput.Cells(2, 1).Value & wsOutput.Cells(2, 3).Value & " " & "REV_" & wsOutput.Cells(2, 6).Value
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
ws.PageSetup.LeftHeader = "&G"
Finish1:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
