I know this has been raised many times (often under Run-time error '1004') but I am having difficulties isolating the error in my code - despite extensive research both here and other sites. My code runs from a command button on an Access form and runs successfully the first time after opening the form, but fails on subsequent attempts. I think I am using inadequate references and/or opening a second Excel object but I can't work out how.
Other formatting is carried out, but I have removed as much as possible to keep it short.
Private Sub cmdExport_Click()
Dim dbs As Database
Dim rst As DAO.Recordset
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim lngCount As Long
Dim lngDataRows As Long
Dim intLoop As Integer
Dim strSheetName As String
Dim dteStart As Date
Dim dteEnd As Date
Dim curStartBal As Currency
Dim intMoves As Integer
Dim lngCol As Long
Dim lngRow As Long
Dim intField As Integer
Dim intFieldCount As Integer
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim blnFileCheck As Boolean
strFile = "BudgetForecast.xlsx"
strPath = genFindFolder("tblSettings") 'provides path to data store
strPathFile = strPath & strFile
blnFileCheck = genDeleteFile(strPath, strFile) 'Deletes existing file if it exists
dteStart = DateAdd("m", 1, Date)
dteEnd = DateAdd("m", 12, Date)
strSheetName = "Forecast " & MonthName(Month(dteStart), True) & " " & CStr(Year(dteStart)) 'Start Month and Year
strSheetName = strSheetName & " To " & MonthName(Month(dteEnd), True) & " " & CStr(Year(dteEnd)) 'Add End Month and Year
curStartBal = [Forms]![frmBudForecast]![txtStart1]
'Create new Excel Workbook and add data
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("qryBudForecastFinal")
Set appExcel = New Excel.Application
Set wbk = appExcel.Workbooks.Add
Set wks = wbk.ActiveSheet
appExcel.Visible = True
With wks
.Name = strSheetName
.Cells(1, 1).Value = "Sort"
.Cells(1, 2).Value = "Date"
.Cells(1, 3).Value = "Type"
.Cells(1, 4).Value = "Account"
.Cells(1, 5).Value = "Payee/Details"
.Cells(1, 6).Value = "Jan"
' lines for Feb to Nov removed to shorten extract
.Cells(1, 17).Value = "Dec"
.Cells(1, 18).Value = "Totals"
rst.MoveLast
rst.MoveFirst
lngCount = rst.RecordCount
intFieldCount = rst.Fields.Count
lngDataRows = lngCount + 5
rst.MoveFirst
Do Until rst.EOF
lngCol = 1
lngRow = .[A65536].End(3).Row + 1
For intField = 0 To intFieldCount - 1
.Cells(lngRow, lngCol) = rst.Fields(intField).Value
lngCol = lngCol + 1
Next intField
rst.MoveNext
Loop
'Shift columns around to correct order
If Month(Date) <> 12 Then 'If December, records are already in correct order
intMoves = Month(Date)
For intLoop = 1 To intMoves
.Columns("R:R").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '###Error here
.Columns("F:F").Select
Selection.Cut Destination:=Columns("R:R")
.Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Next intLoop
End If
End With
'Save new file (next line commented-out for testing)
'appExcel.ActiveWorkbook.SaveAs FileName:=strPathFile, ConflictResolution:=xlOtherSessionChanges
'Close Excel
appExcel.ActiveWindow.Close (False)
'Cleanup
rst.Close
Set rst = Nothing
Set dbs = Nothing
Set wks = Nothing
Set wbk = Nothing
appExcel.Quit 'Not sure if this line is necessary
Set appExcel = Nothing
End Sub
Error occurs on this line:
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
and 'Selection' appears to be 'Nothing'.
I've tried all sorts of variations and amendments to the syntax - I suspect I need to be more specific with the selection of column R, but I don't know how. Incidentally, when the code fails, column R on the spreadsheet is selected.
I'm tempted just to hide the command button on the form after it has been clicked, but fear this would be a cop-out and certainly wouldn't help my understanding.
appExcel.Selection
Selection is not part of the Access object model. But you should try to avoid using select/activate where possible. For example:
.Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
would be better written as:
.Columns("F:F").Delete Shift:=xlToLeft
How to avoid using Select in Excel VBA
Related
I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
My problem is when closing workbook2 I need to use code to automatically select No on a message box that pops up. This is how my code is laid out:
Workbook1 creates multiple files based on user input.
The loop in Workbook1 opens up Workbook2 and inputs data from Workbook1.
When the loop is done inputing data it closes workbook2 and a message box pops up with a Yes or No button on it.
User at this time should always select No.
Another window ask if the user would like to save and it should always be yes.
Loop continues until it has created all the files user has requested
I tried googling variations of my question but have not had much luck. Any help is much appreciated.
Dim JobName As String
Dim lngLoop As Long
Dim i As Integer
Dim Customer As String
Dim LastRow As Long
Dim iCus As Integer
Dim CompanyName As String
Dim d As Long
Dim strDir As Variant
Dim DIV As String
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim ActSheet As Worksheet
Dim ActBook As Workbook
Dim CurrentFile As Workbook
Dim NewFileType As String
Dim NewFile As String
Dim QTR_NUM As String
Dim MFG As String
Dim Job As String
Dim visitdate As Variant
Dim visitdate_text As String
Dim Quote_Request As Worksheet
Dim QTR As Workbook
Dim QTRLOG As Workbook
Dim FORM As Workbook
Dim DCSProgram As Workbook
Dim ILast As Long
Dim j As Integer
Dim k As Integer
Dim CustomerIDNum As String
Dim QTRNUM As String
Dim FolderName As String
'Creates Quote For Each MFG
For j = 0 To QTRList.ListCount - 1
Set QTRLOG = Workbooks.Open("C:\QTR LOG.xlsm")
Set QTR = Workbooks.Open("C:\QTR.xlsx")
'CODE TO INPUT DATA FROM USERFORM NEW QTR
With DCSProgram.Sheets("MFG_DATA")
ILast = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = MFG Then
QTR.Sheets(1).Range("B7").Value = .Cells(i, 2).Value
QTR.Sheets(1).Range("B8").Value = .Cells(i, 3).Value
QTR.Sheets(1).Range("B9").Value = .Cells(i, 4).Value
QTR.Sheets(1).Range("B12").Value = .Cells(i, 5).Value
QTR.Sheets(1).Range("B13").Value = .Cells(i, 6).Value
QTR.Sheets(1).Range("B14").Value = .Cells(i, 7).Value
QTR.Sheets(1).Range("B15").Value = .Cells(i, 8).Value
End If: Next: End With
With QTRLOG.Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 2) = QTRList.List(j)
'.Cells(i, 3) = FORM.Sheets(1).Range("H11").Value
.Cells(i, 5) = JobName
.Cells(i, 8) = "OPEN"
.Cells(i, 9) = QTR.Sheets(1).Range("H9").Value
End If: Next: End With
QTRLOG.Save
QTRLOG.Close
QTR.SaveAs Filename:="C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS\" & JobName & "\" _
& " DCS QTR " & QTRList.List(j) & " " & JobName & " (" & CustomerIDNum & ") " & visitdate_text & " .xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
'Code To Close File After Creating It
QTR.Close
Next j
End If
Application.ScreenUpdating = True
Call Shell("explorer.exe" & " " & "C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS", vbNormalFocus)
Unload NewQTR
End Sub
When this code runs a msgbox appears from the workbook QTR. I dont want the user to have to click yes or no at this time. I want to automatically select No and continue on to the next file. This process is repeated for each MFG.
Code in QTR:
Application.ScreenUpdating = True
MSG1 = MsgBox("Are you ready to email to MFG?", vbYesNo, "EMAIL MFG")
If MSG1 = vbYes Then
'Code to create email and attached workbook as PDF
Else
Const kPath As String = "C:\"
Const kFile As String = "Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\9. PROGRAM FILES\1. QUOTE REQUEST\QUOTE REQUEST LOG.xlsm"
Dim TOTALFOB As Double
Dim TOTALWC As Double
Dim Wbk As Workbook
Dim INWBK As Workbook
Dim QTR_NUM As String
Dim ILast As Long
Dim i As Long
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim LR As Long
Dim TOTALTIME As Variant
Set INWBK = ThisWorkbook
With Sheets("QTR")
LR = .Range("I" & Rows.Count).End(xlUp).Row
TOTALFOB = WorksheetFunction.Sum(.Range("I23:I" & LR))
End With
TOTALWC = TOTALFOB + INWBK.Sheets("QTR").Range("D18").Value
QTR_NUM = INWBK.Sheets("QTR").Range("H7").Value
TOTALTIME = INWBK.Sheets("WS_LOG").Range("J3").Value
Rem Set Wbk in case it's open
On Error Resume Next
Set Wbk = Workbooks(kFile)
On Error GoTo 0
Rem Validate Wbk
If Wbk Is Nothing Then Set Wbk = Workbooks.Open(kPath & kFile)
With Workbooks("QUOTE REQUEST LOG.xlsm").Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 6) = TOTALFOB
.Cells(i, 7) = TOTALWC
.Cells(i, 10) = TOTALTIME
End If: Next: End With
Wbk.Save
Wbk.Close
End If
End Sub
If your problem is avoiding some Workbook_BeforeClose() event handler placed in "ThisWorkbook" code to be executed, then you must "enclose" the code lines that close the workbook like follows
Application.EnableEvents = False
' your code that closes the workbook
Application.EnableEvents = True
Exit Sub before end if is making the code exit earlier.
So remove the above mentioned one and check.
This code is for updating client information in my source document for a mail merge from a list that I can pull from my client server at any time.
I've hit a snag in this code near the end. The process it currently goes through is as follows:
user selects the merge document that needs to be updated
user selects the list with the updated addresses
code steps through the merge document, grabs the name of a company, then
searches through the second document for that company, copies the address information from the list, and
pastes it next to the company name in the merge document and
starts over with the next company name in the merge document
I'm currently stuck between steps four and five.'
here's a selection of the code I'm trying to adapt to search the source workbook, but I think this isn't going to work - I need to paste the found term into the macro workbook, and I have a gap in my knowledge of VBA here.
I can post my full code if necessary, but I didn't want to throw the whole thing in right away.
Thanks in advance!
Set sourcewkb = ActiveWorkbook
Dim rnnng As Range
Dim searchfor As String
Debug.Print celld
searchfor = celld
Set rnnng = Selection.Find(what:=searchfor)
If rnnng Is Nothing Then
Debug.Print "yes"
Else
Debug.Print "no"
End If
EDIT
I tried some of what was suggested in the comment, but I'm having an issue where the selection.find is finding the variable in question whether or not it's actually there. I think somehow it's searching in both workbooks?
Full code (some parts are marked out as notes for convenience during editing the code, they generally aren't the parts I'm concerned about):
UPDATED full code:
Sub addressfinder()
Dim rCell
Dim rRng As Range
Dim aftercomma As String
Dim celld As String
Dim s As String
Dim indexOfThey As Integer
Dim mrcell As Range
Dim alreadyfilled As Boolean
Dim nocompany As Boolean
Dim sourcewkb
Dim updaterwkb
Dim fd As FileDialog
Dim cellstocopy As Range
Dim cellstopaste As Range
Dim x As Byte
'select updater workbook
updaterwkb = "L:\Admin\Corporate Books\2015\letter macro\Annual Consent Letter Macro.xlsm"
'this is the finished updater workbook selecter.
' Set fd = Application.FileDialog(msoFileDialogFilePicker)
'
'
' Dim vrtselecteditem As Variant
' MsgBox "select the Annual Consent Letter Macro workbook"
'
' With fd
' If .Show = -1 Then
' For Each vrtselecteditem In .SelectedItems
'
'
' updaterwkb = vrtselecteditem
' Debug.Print updaterwkb
' Next vrtselecteditem
' Else
' End If
' End With
'select file of addresses
sourcewkb = "L:\Admin\Corporate Books\2015\letter macro\source workbook_sample.xlsx"
'this is the finished source select code
' Dim lngcount As Long
' If MsgBox("Have you gotten this year's updated contact list exported from Time Matters or Outlook?", vbYesNo, "confirm") = vbYes Then
' If MsgBox("Is the information in that excel workbook formatted per the instructions?", vbYesNo, "Confirm") = vbYes Then
' MsgBox "Good. Select that workbook now."
' Else
' MsgBox "Format the workbook before trying to update the update list"
' End If
' Else
' MsgBox "Have someone export you a client list with company name, client name, and client address"
'
' End If
'
'
' With Application.FileDialog(msoFileDialogOpen)
' .AllowMultiSelect = False
' .Show
' For lngcount = 1 To .SelectedItems.Count
' Debug.Print .SelectedItems(lngcount)
' sourcewkb = .SelectedItems(lngcount)
'
' Next lngcount
' End With
'
Workbooks.Open (sourcewkb)
'start the code
Set updaterwkb = ActiveWorkbook
Set rRng = Sheet1.Range("a2:A500")
For Each rCell In rRng.Cells
'boolean resets
alreadyfilled = False
nocompany = False
'setting up the step-through
s = rCell.Value
indexOfThey = InStr(1, s, ",")
aftercomma = Right(s, Len(s) - indexOfThey + 1)
celld = Left(s, Len(s) - Len(aftercomma))
Debug.Print rCell.Value, "celld", celld
Debug.Print "address", rCell.Address
'setting up already filled check
Set mrcell = rCell.Offset(rowoffset:=0, ColumnOffset:=6)
Debug.Print "mrcell", mrcell.Value
If Len(rCell.Formula) = 0 Then
Debug.Print "company cell sure looks empty"
nocompany = True
End If
If Len(mrcell.Formula) > 0 Then
Debug.Print "mrcell has content"
alreadyfilled = True
Else: Debug.Print "mrcell has no content"
End If
If alreadyfilled = False Then
If nocompany = False Then
'the code for copying stuff
'open source document
'search source document for contents of celld
'if contents of celld are found, copy everything to the right of the cell in which
'they were found and paste it horizontally starting at mrcell
'if not, messagebox "address for 'celld' not found
'Set sourcewkb = ActiveWorkbook
'
'Dim rnnng As Range
'Dim searchfor As String
'Debug.Print celld
'searchfor = celld
'
'Set rnnng = Selection.Find(what:=searchfor)
'If Not rnnng Is Nothing Then
' Debug.Print "yes"
' Else
' Debug.Print "no"
'
'End If
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("source workbook_sample.xlsx") 'change workbook name
Set ws1 = ThisWorkbook.Worksheets(1) 'change worksheet #
Set ws2 = wb2.Worksheets(1) 'change worksheet #
llc = ",LLC"
inc = ",INC."
'lastRow = ws1.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
'
Else
Debug.Print "skipped cuz there ain't no company"
End If
Else
Debug.Print "skipped cuz it's filled"
End If
''
'
Debug.Print "next"
Next rCell
End Sub
fixed code:
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String
Set wb1 = ThisWorkbook 'Annual Consent Letter Macro
Set wb2 = Workbooks("source workbook_sample.xlsx")
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = wb2.Worksheets(1)
llc = ",LLC"
inc = ",INC."
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:A500").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
End Sub
I'm not experienced with VBA, but I think it's the only way for this to work.
I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.
I would like all the sheets to be filtered by sales team, and create a new workbook for each team.
I appreciate any help.
I got this solution.
Just send me an email if you need this solution.
At first I got this format:
I create the following macro code
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"
End Sub
Following is the output
I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.
enter Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
please find below code
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim icol As Long
Dim l As Long
Dim headercol As Long
Dim stroutputfolder As String
stroutputfolder = "D:\Ba"
'dim str
icol = 1
headercol = 3
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = headercol + 1 To nLastRow
'Get the specific Column
'Here my instance is "B" column
'You can change it to your case
strColumnValue = objWorksheet.Cells(nRow, icol).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'MsgBox (varColumnValues(i))
If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
If CStr(varColumnValue) <> "" Then
objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
'strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
ActiveWorkbook.Close savechanges:=False
l = l + 1
End If
Next
objWorksheet.ShowAllData
MsgBox (l & " files splitted")
End Sub
i am attempting to write a script that goes over a specific column and then copies all rows containing the value of "rejected" in said column to a new excel file/workbook.
Everything seems to work just fine except for the actual Paste command which fails every time.
The code:
Sub button()
Dim x As String
Dim found As Boolean
strFileFullName = ThisWorkbook.FullName
strFileFullName = Replace(strFileFullName, ".xlsm", "")
strFileFullName = strFileFullName + "_rejected.xlsx"
' MsgBox strFileFullName
Set oExcel = CreateObject("Excel.Application")
Set obook = oExcel.Workbooks.Add(1)
Set oSheet = obook.Worksheets(1)
oSheet.Name = "Results"
' Select first line of data.
Range("E2").Select
' Set search variable value.
x = "rejected"
' Set Boolean variable "found" to false.
found = False
' Set Do loop to stop at empty cell.
Do Until IsEmpty(ActiveCell)
' Check active cell for search value.
If ActiveCell.Value = "" Then
Exit Do
End If
If ActiveCell.Value = x Then
found = True
rowToCopy = ActiveCell.Row
ActiveSheet.Rows(ActiveCell.Row).Select
Selection.Copy
oSheet.Range("A1").Select
lastrow = oSheet.Cells(Rows.Count, "B").End(xlUp).Row
' oSheet.Rows(1).Select.PasteSpcial
End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
' Check for found.
If found = True Then
MsgBox "Value found in cell " & ActiveCell.Address
Else
MsgBox "Value not found"
End If
obook.SaveAs strFileFullName
obook.Close
End Sub
Any idea why i keep failing with the paste function?
Thanks!
Try this, no selects involved.
Sub AddWB()
Dim nwBk As Workbook, WB As Workbook, Swb As String
Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet
Set WB = ThisWorkbook
Set sh = WB.Worksheets("Sheet1")
Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))
Set nwBk = Workbooks.Add(1)
Swb = WB.Path & "\" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
MsgBox Swb
For Each c In Rng.Cells
If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Next c
nwBk.SaveAs Filename:=Swb
End Sub
XLorate.com
Your PasteSpecial command might fail because it's spelled incorrectly. At any rate, if you've got a lot of rows, you should consider something faster than looping through them.
This uses AutoFilter to copy all rows meeting the criteria in one pass. It will also copy the header row. If that's not what you want, you can delete row 1 of the new worksheet after the copy:
Sub CopyStuff()
Dim SearchString As String
Dim Found As Boolean
Dim wsSource As Excel.Worksheet
Dim wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
Dim LastRow As Long
Set wsSource = ActiveSheet
SearchString = "rejected"
With wsSource
Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
If Not Found Then
MsgBox SearchString & " not found"
Exit Sub
End If
Set wbTarget = Workbooks.Add(1)
Set wsTarget = wbTarget.Worksheets(1)
wsTarget.Name = "Results"
.Range("E:E").AutoFilter
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
.Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
.Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=wsTarget.Range("A1")
End With
wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
wbTarget.Close
End Sub
I didn't use your code to create a new Excel instance, as I couldn't see why that would be needed here, and it could cause problems. (For example,yYou don't kill the instance in your original code.)