Update:
Its now populating the sheets, but it does not distinguish between years. It will populate the sheet with data from all years, even if I choose '2015'.
PHP Code:
Private Sub UserForm_Initialize()
With ComboBox1
.AddItem "2015"
.AddItem "2016"
.AddItem "2017"
.AddItem "2018"
End With
Lbl_exit:
Exit Sub
End Sub
PHP Code:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Fpass As Boolean
Dim i As Long
Dim lrow As Long
Dim Rlrow As Long
Dim ws As Worksheet
Dim AllCells As Range
Dim cell As Range, Rng As Range
Dim Dcell As Range
Dim NoDupes As New Collection
Dim wBook As Workbook
Dim Drng As Range
Dim Myval As Integer
Dim VenFile As String
Dim MyPath As String
Dim TempPath As String '' for Template
Dim Newwb As String '' for New Vendor
Dim Twb As Workbook
Dim Thswb As Workbook
Set Thswb = ActiveWorkbook
Fpass = False
MyPath = ThisWorkbook.Path ''' set your path using the workbook path
TempPath = "C:\Users\thomasb\Desktop\Test\Macro\Vendor Template1.xltx" ''' you need to update this to your path
'' be sure it's in the same path as the Data workbook
Newwb = "C:\Users\thomasb\Desktop\Test\Macro\" ''' you need to update this to your path
'' be sure it's in the same path as the Data workbook
Newwb = "C:\Users\thomasb\Desktop\Test\Macro\"
Set ws = Sheets("Sheet1") '''' change to your sheet name in data file
With ws
lrow = .Range("A65536").End(xlUp).Row
Set AllCells = Range("A2:A" & lrow)
''' We will load the filter with out duplicate vendors''
For Each cell In AllCells
On Error Resume Next
NoDupes.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0
For Each Item In NoDupes
'''''set filter for vendor '''
Range("A1:F1").Select
Selection.AutoFilter
With Selection
.AutoFilter field:=1, Criteria1:=Item '' this set the filtered data for the value
End With
Set Rng = ActiveSheet.AutoFilter.Range
'' make sure you have more than 1 row to copy ''
Myval = Range("A2:A" & lrow).SpecialCells(xlCellTypeVisible).Count
If Myval >= "1" Then
'''' First open Vendor workbook then populate the data to Sheet1 and Sheet2 '''
Set Drng = Range("A2", Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
On Error Resume Next
Workbooks.Open Filename:=MyPath & "\" & Item & ".xlsx", UpdateLinks:=0
If Err = "1004" Then '' this will add New Vendor workbook and populate
Fpass = False
Workbooks.Open Filename:=TempPath, UpdateLinks:=0, Editable:=True
ActiveWorkbook.SaveAs Filename:=Newwb & Item & ".xlsx", FileFormat:=xlOpenXMLWorkbook _
, CreateBackup:=False
For Each Dcell In Drng
Rlrow = ActiveWorkbook.Sheets("Sheet2").Range("B301").End(xlUp).Row + 1
''' Populate Declaration ''''
If Fpass = False Then
ActiveWorkbook.Sheets("Sheet1").Range("D8").Value = ws.Cells(Dcell.Row, 1).Text
ActiveWorkbook.Sheets("Sheet1").Range("D12").Value = ws.Cells(Dcell.Row, 2).Text
Fpass = True
End If
''''''' Populate Sheet2 ActiveWorkbook.Sheets("Sheet2").Cells(Rlrow, 2).Value = ws.Cells(Dcell.Row, 3).Text
ActiveWorkbook.Sheets("Sheet2").Cells(Rlrow, 3).Value = ws.Cells(Dcell.Row, 4).Text
ActiveWorkbook.Sheets("Sheet2").Cells(Rlrow, 4).Value = ws.Cells(Dcell.Row, 5).Text
Next Dcell
Else
For Each Dcell In Drng
Rlrow = ActiveWorkbook.Sheets("Sheet2").Range("B301").End(xlUp).Row + 1
''' Populate Sheet1 ''''
If Fpass = False Then
''''''' first remove existing data in Sheet2 ''''
ActiveWorkbook.Sheets("Sheet2").Range("B6:D" & Rlrow).ClearContents
'''''''''''''''''''''''''''''''''''''''''''''
ActiveWorkbook.Sheets("Sheet1").Range("D8").Value = ws.Cells(Dcell.Row, 1).Text
ActiveWorkbook.Sheets("Sheet1").Range("D12").Value = ws.Cells(Dcell.Row, 2).Text
Fpass = True
Rlrow = ActiveWorkbook.Sheets("Sheet2").Range("B301").End(xlUp).Row + 1
End If
ActiveWorkbook.Sheets("Sheet2").Cells(Rlrow, 2).Value = ws.Cells(Dcell.Row, 3).Text
ActiveWorkbook.Sheets("Sheet2").Cells(Rlrow, 3).Value = ws.Cells(Dcell.Row, 4).Text
ActiveWorkbook.Sheets("Sheet2").Cells(Rlrow, 4).Value = ws.Cells(Dcell.Row, 5).Text
Next Dcell
End If
Exit Sub
End If
ActiveWorkbook.Close savechanges:=True '''' Close and save the current Sheet
Next Item
End With
Application.DisplayAlerts = True
End Sub
04-16-2015, 10:13 AM
Similar Threads
Creating a table that automatically updates based on entries of a heading in the document
Windows 7 64bit 
Office 2010 64bit
Linear Mode
