I have a workbook that has some 100,000+ number of lead records. Each record has an agent code which determines to whom the record is allotted to(50 plus agents). What I would like to do is to distribute all lead records per agent(workbook) depending on the agent code while also maintaining the existing data formatting, data validation and also automatically creating a worksheet password. Is this possible with excel VBA?
The table runs by this sequence:
enter image description here
EDIT:
Here are some of the sample scripts we ran:
Sub ExtractToNewWorkbook()
Dim ws As Worksheet
Dim wsNew As Workbook
Dim rData As Range
Dim rfl As Range
Dim state As String
Dim sfilename As String
Set ws = ThisWorkbook.Sheets("emp")
'Apply advance filter in your sheet
With ws
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 11).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, .Columns.Count), _
Unique:=True
For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state = rfl.Text
Set wsNew = Workbooks.Add
sfilename = state & ".xlsx"
'Set the Location
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sfilename
Application.DisplayAlerts = False
ws.Activate
rData.AutoFilter Field:=6, Criteria1:=state
rData.Copy
Windows(state).Activate
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next rfl
Application.DisplayAlerts = True
End With
ws.Columns(Columns.Count).ClearContents
rData.AutoFilter
End Sub
Related
I have used bits and pieces of code on forums to create a macro that exports PDF's from a single sheet in excel. Each PDF contains the header and all relevant rows to the employee (all rows with employee ID). When I run it all goes well and the pdfs are correct, however the macro never stops running.
I believe I have created an infinite loop and am not sure how to correct it.
It also creates a PDF just containing the header that is not necessary.
Sub PracticeToPDF()
Dim ws As Worksheet
Dim ws_unique As Worksheet
Dim DataRange As Range
Dim iLastRow As Long
Dim iLastRow_unique As Long
Dim UniqueRng As Range
Dim Cell As Range
Dim LastRow As Long
Dim LastColumn As Long
Application.ScreenUpdating = False
'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
DirectoryLocation = ActiveWorkbook.Path
Set ws = Worksheets("BootVSPayroll") 'Amend to reflect the sheet you wish to work with
Set ws_unique = Worksheets("BootVSPayroll") 'Amend to reflect the sheet you wish to work with
'Find the last row in each worksheet
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
iLastRow_unique = ws_unique.Cells(Rows.Count, "A").End(xlUp).Row
With ws
'I've set my range to reflect my headers which are fixed for this report
Set DataRange = ws.Range("$A$1:$K$1" & iLastRow)
'autofilter field is 4 as I want to print based on the practice value in column D
DataRange.AutoFilter Field:=1
Set UniqueRng = ws_unique.Range("A1:A20" & iLastRow_unique)
For Each Cell In UniqueRng
DataRange.AutoFilter Field:=1, Criteria1:=Cell
Name = DirectoryLocation & "\" & Cell.Value & " BOOT Report" & ".pdf"
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next Cell
End With
With ws
.Protect Userinterfaceonly:=True, _
DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingColumns:=True, AllowFormattingRows:=True
.EnableOutlining = True
.EnableAutoFilter = True
If .FilterMode Then
.ShowAllData
End If
End With
Application.ScreenUpdating = True
End Sub
Did you perhaps mean for:
Set DataRange = ws.Range("$A$1:$K$1" & iLastRow)
...
Set UniqueRng = ws_unique.Range("A1:A20" & iLastRow_unique)
to instead be:
Set DataRange = ws.Range("$A$1:$K$" & iLastRow)
...
Set UniqueRng = ws_unique.Range("A1:A" & iLastRow_unique)
?
If, for example, (taken from ws_unique) your last used row, iLastRow_unique equals 200, then "A1:A20" & iLastRow_unique is equivalent to "A1:A20200" -- which may be a lot more rows that you intended to loop through, I think.
What I am trying to do is:
create new Sheet in my Active Workbook (wsData)
Open workbook with Filename (wbimport)
Autofilter for Array (arrCriteriaPH1())
Copy filtered Cells from wbimport into wsData in my initial Workbook.
My Problem:
The code works only sometimes, even though I don't change anything. Sometimes both worksheets get generated, sometimes only one and I get the error of paste special method of Range Class failed. Import data is always the same.
I tried to reduce the code as much as possible. Hopefully someone is able to help!
Error appears almost at the end of the loop:
wsData.Cells.ClearContents
wbImport.Worksheets("Data").UsedRange.SpecialCells(xlCellTypeVisible).Copy
wsData.Range("J1").PasteSpecial Paste:=xlPasteValues
For Each i In Dates()
Dim App As New Excel.Application 'create a new (hidden) Excel
'create new sheet for new data'
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = i
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Sheets(i)
wsData.Cells.ClearContents
' open the import workbook in new Excel (as read only)
Dim wbImport As Workbook
Dim FileN As String
FileN = "\\10.64.1.151\Load And Cover\Load And Cover_Ops Internal\Load_and_Cover_" & Format(i, "YYYY-MM-DD") & ".xlsb"
Set wbImport = App.Workbooks.Open(Filename:=FileN, UpdateLinks:=True, ReadOnly:=True)
'wbImport.Worksheets("Data").Activate'
'Array for Autofilter criteria'
Dim lngCriteriaCountPH1 As Long
Dim arrCriteriaPH1() As String
lngCriteriaCountPH1 = 6
ReDim arrCriteriaPH1(0 To lngCriteriaCountPH1 - 1)
arrCriteriaPH1(0) = "Commercial All-In-One"
arrCriteriaPH1(1) = "Commercial Desktop"
arrCriteriaPH1(2) = "Commercial Notebook"
arrCriteriaPH1(3) = "Commercial Tablet"
arrCriteriaPH1(4) = "Visuals"
arrCriteriaPH1(5) = "Workstation"
'Autofilter aktivieren'
Dim LastRowColumnA As Long
LastRowColumnA = wbImport.Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long
LastCol = wbImport.Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
colletter = Split(Cells(1, LastCol).Address, "$")(1)
Set rngFilterRange = wbImport.Worksheets("Data").Range("A1:" & colletter & LastRowColumnA)
rngFilterRange.AutoFilter
rngFilterRange.AutoFilter Field:=2, Criteria1:="GAT", Operator:=xlFilterValues
rngFilterRange.AutoFilter Field:=7, Criteria1:=arrCriteriaPH1(), Operator:=xlFilterValues
rngFilterRange.AutoFilter Field:=19, Criteria1:="Y", Operator:=xlFilterValues
'copy the data of the import sheet
wsData.Cells.ClearContents
wbImport.Worksheets("Data").UsedRange.SpecialCells(xlCellTypeVisible).Copy
wsData.Range("J1").PasteSpecial Paste:=xlPasteValues
App.CutCopyMode = False 'clear clipboard (prevents asking when wb is closed)
wbImport.Close SaveChanges:=False 'close wb without saving
App.Quit 'quit the hidden Excel
Next i
I am trying to take one master document and split it into seperate excel files based on the values in my column "Business Unit". The new sheets will be named after their business unit and they should contain only the data in the rows containing that particular business unit. IE all ACH labeled rows need to be in the new ach folder. This code is currently making the sheets based on segment "column A". It is also only giving me the data in those rows that match the segment name IE instead of getting ACH ACH and ACH ACH 1 ACH ACH2 I am just getting ACH ACH.So I either set up my filtering wrong or i set up my copying wrong. I just can't tell.
Sub ExtractToNewWorkbook()
Dim ws As Worksheet
Dim wsNew As Workbook
Dim rData As Range
Dim rfl As Range
Dim Business_Unit As String
Dim sfilename As String
Set ws = ThisWorkbook.Sheets("All Functions Final")
'Apply advance filter in sheet
With ws
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 10).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
Business_Unit = rfl.Text
Set wsNew = Workbooks.Add
sfilename = Business_Unit & ".xlsx"
'Set the Location
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sfilename
Application.DisplayAlerts = False
ws.Activate
rData.AutoFilter Field:=2, Criteria1:=Business_Unit
rData.Copy
Windows(Business_Unit).Activate
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next rfl
Application.DisplayAlerts = True
End With
ws.Columns(Columns.Count).ClearContents
rData.AutoFilter
End Sub
I have prepared a macro which works fine in demo sheet but gives a 1004 runtime error when it put it in the final sheet.
Below is my code:
Private Sub CommandButton3_Click()
'Declaring the Variables
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim rng As Range
Dim startdate As Long
Dim enddate As Long
Dim tbl As ListObject
Dim fname As Variant
'Assigning the Variables
Set ws = Sheets("Reports")
Set ws3 = Sheets("Report Format")
Set rng = ws.Range("E7")
startdate = ws.Range("L10").Value
enddate = ws.Range("L12").Value
'Find the Worksheet against the Name selected in Drop Down List
For Each ws1 In Worksheets
If rng.Value = ws1.Name Then
Sheets(rng.Value).Activate
End If
Next
'Filter the data based on the Date Range Entered
Set ws2 = ActiveSheet
Set tbl = ws2.ListObjects(1)
Range(tbl & "[[Date]:[Cheque #]]").Select
Selection.AutoFilter Field:=1, Criteria1:=">=" & startdate, Operator:=xlAnd, Criteria2:="<=" & enddate
Selection.Copy
ws2.Range("A10").Select
'Paste the Data in the Report Format
ws3.Activate
ws3.Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
'Create the PDF of the Report
fname = Application.GetSaveAsFilename(InitialFileName:=rng.Value, filefilter:="PDF files, *.pdf", Title:="Export to PDF")
If fname <> False Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fname_, quality:=xlQualityStandard, includedocproperties:=True, ignoreprintareas:=False, openafterpublish:=True
End If
'Clear the Report format Sheet for Future Printing
With ActiveSheet
.Rows(10 & ":" & .Rows.Count).Delete
End With
'Activate the Report Sheet
ws.Activate
'Unfilter all the Tables present in Workbook
Dim w As Long
For w = 1 To Worksheets.Count
With Worksheets(w)
**.UsedRange.Cells.EntireRow.Hidden = False**
If .AutoFilterMode Then .ShowAllData
End With
Next w
End Sub
Error appears in line which is highlighted in commas. Kindly review and debug.
You are trying to concatenate a ListObject object into a string. You need the ListObject.Name property.
Dim ws2 As Worksheet, tbl As ListObject
Set ws2 = ActiveSheet
Set tbl = ws2.ListObjects(1)
Debug.Print tbl.Name
Range(tbl.Name & "[[Date]:[Cheque '#]]").Select
Please note that there is also a tick (aka ' or Chr(39)) escaping the hashmark in [Cheque '#].
I have checked a bunch of different posts and can't seem to find the exact code I am looking for. Also I have never used VBA before so I'm trying to take codes from other posts and input my info for it to work. No luck yet. At work we have a payroll system in Excel. I am trying to search for my name "Clarke, Matthew" and then copy that row and paste it to the workbook I have saved on my desktop "Total hours".
CODE
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("yourSheetName")
strSearch = "Clarke, Matthew"
With ws1
'~~> Remove any filters
.AutoFilterMode = False
'~~> I am assuming that the names are in Col A
'~~> if not then change A below to whatever column letter
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = Application.Workbooks.Open("C:\Sample.xlsx")
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
wb2.Save
wb2.Close
End Sub
SNAPSHOT
Expanding on what timrau said in his comment, you can use the AutoFilter function to find the row with your name in it. (Note that I'm assuming you have the source workbook open)
Dim curBook As Workbook
Dim targetBook As Workbook
Dim curSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Integer
Set curBook = ActiveWorkbook
Set curSheet = curBook.Worksheets("yourSheetName")
'change the Field number to the correct column
curSheet.Cells.AutoFilter Field:=1, Criteria1:="Clarke, Matthew"
'The Offset is to remove the header row from the copy
curSheet.AutoFilter.Range.Offset(1).Copy
curSheet.ShowAllData
Set targetBook = Application.Workbooks.Open "PathTo Total Hours"
Set targetSheet = targetBook.WorkSheet("DestinationSheet")
lastRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
targetSheet.Cells(lastRow + 1, 1).PasteSpecial
targetBook.Save
targetBook.Close
As you can see I put placeholders in for the specific setup of your workbook.
I know this is old, but for anyone else searching for how to do this, it can be done in a much more direct fashion:
Public Sub ExportRow()
Dim v
Const KEY = "Clarke, Matthew"
Const WS = "Sheet1"
Const OUTPUT = "c:\totalhours.xlsx"
Const OUTPUT_WS = "Sheet1"
v = ThisWorkbook.Sheets(WS).Evaluate("index(a:xfd,match(""" & KEY & """,a:a,),)")
With Workbooks.Open(OUTPUT).Sheets(OUTPUT_WS)
.[1:1].Offset(.[counta(a:a)]) = v
.Parent.Save: .Parent.Close
End With
End Sub