I have this code where,
Worksheet: "Main" B3: what I am searching for in the file.
worksheet "AX": where to search.
I want to search in another opened workbook beginning with the letters: ECL_
Sub FindandKopy()
Dim CellContents As String
Dim rng As Range
Dim loDeinWert As String
Dim sfirstaddress As String
loDeinWert = Worksheets("main").Range("B3").Value
Set rng = Worksheets("AX").Range("B:B").Find(loDeinWert)
If rng Is Nothing Then
MsgBox "Data " & loDeinWert & " not found!"
Else
sfirstaddress = rng.Address
Do
rng.EntireRow.Copy
Worksheets("Main").Cells(Rows.Count, "A").End(xlUp) _
.Offset(6, 0).PasteSpecial Paste:=xlPasteAll
Set rng = Worksheets("AX").Range("B:B").FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> sfirstaddress
End If
End Sub
If you need to find a workbook that is already opened you could loop through all workbooks and check each workbooks name:
Dim ECLWb As Workbook
Dim wb As Workbook
For Each wb in Application.Workbooks
If wb.Name Like "ECL_*" Then
Set ECLWb = wb
Exit For
End If
Next wb
If ECLWb Is Nothing Then
MsgBox "ECL_* not found."
Exit Sub
Else
'use that workbook like
ECLWb.Worksheets("AX")…
End If
Related
I'm trying to run this code in excel from another application.The code runs without problems, however rngNumber.Copy wsData.Range("A2") isn't copied. I've tested the same code directly in excel and it was copied perfectly. I think that maybe rngNumber isn't set properly when the code is runned from another application. But, I don't get exactly the reason. Any suggestion would be appreciate, thanks.
Sub TEST()
' Try to connect to a running instance of Excel.
Dim excelApp As Excel.Application
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
' Couldn't connect so start Excel. It's started invisibly.
Set excelApp = CreateObject("Excel.Application")
If Err Then
MsgBox "Cannot access excel."
Exit Sub
End If
End If
' You can make it visible if you want. This is especially
' helpful when debugging.
excelApp.Visible = True
'Open the excel file (through dialog)
Dim ExcelFilePath As Variant
ExcelFilePath = excelApp.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If ExcelFilePath <> False Then
Set wb = excelApp.Workbooks.Open(ExcelFilePath)
End If
' Open the excel file
Dim wb as Workbook
Set wb = excelApp.ActiveWorkbook
Dim ws as Worksheet
Set ws = wb.Worksheets(1)
ws.Activate
'Set Worksheet
Dim wsData As WorkSheet
Set wsData = wb.Worksheets(2)
'Write column titles
With wsData
.Cells(1, "A").Value = "Number"
End With
'Get column letter for each column whose first row starts with an specific string
ws.Activate
Dim sNumber as String
sNumber= Find_Column("Number")
'Define variables
Dim rngNumber As Range
' Copy and paste data from "Number" column to Column "A" in Worksheets "Data"
ws.Activate
'Find which is the last row with data in "Number" column and set range
With ws.Columns(sNumber)
Set rngNumber = Range(.Cells(2), .Cells(.Rows.Count).End(xlUp))
End With
'Copy and paste data from "Number" column
rngNumber.Copy wsData.Range("A2")
End Sub
Private Function Find_Column(Name As String) As String
Dim rngName As Range
Dim Column As String
With ws.Rows(1)
On Error Resume Next
Set rngName = .Find(Name, .Cells(.Cells.Count), xlValues, xlWhole)
' Calculate Name Column Letter.
Find_Column = Split(rngName.Address, "$")(1)
End With
End Function
Explicitly define the excel object and remove the On Error Resume Next. This works from Word.
Option Explicit
Sub TEST()
' Try to connect to a running instance of Excel.
Dim excelApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.WorkSheet, wsData As Excel.WorkSheet
Dim rngNumber As Excel.Range
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
' Couldn't connect so start Excel. It's started invisibly.
Set excelApp = CreateObject("Excel.Application")
If Err Then
MsgBox "Cannot access excel."
Exit Sub
End If
End If
On Error GoTo 0
' You can make it visible if you want. This is especially
' helpful when debugging.
excelApp.Visible = True
excelApp.WindowState = xlMinimized
'Open the excel file (through dialog)
Dim ExcelFilePath As Variant
ExcelFilePath = excelApp.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If ExcelFilePath = False Then
MsgBox "No file not selected"
Exit Sub
End If
Set wb = excelApp.Workbooks.Open(ExcelFilePath)
Set ws = wb.Sheets(1)
Set wsData = wb.Sheets(2)
' Get column letter for each column whose first row
' starts with an specific string
Dim sNumber As String, LastRow As Long
sNumber = Find_Column(ws, "Number")
If sNumber = "#N/A" Then
MsgBox "Column 'Number' not found in " & vbLf & _
"Wb " & wb.Name & " Sht " & ws.Name, vbExclamation
Exit Sub
End If
' Copy and paste data from "Number" column to Column "A" in Worksheets "Data"
' Find which is the last row with data in "Number" column and set range
With ws
LastRow = .Cells(.Rows.Count, sNumber).End(xlUp).Row
Set rngNumber = .Cells(1, sNumber).Resize(LastRow)
End With
'Copy and paste data from "Number" column
rngNumber.Copy wsData.Range("A1")
excelApp.WindowState = xlMinimized
MsgBox LastRow & " rows copied from column " & sNumber, vbInformation
End Sub
Private Function Find_Column(ws, Name As String) As String
Dim rngName As Excel.Range
With ws.Rows(1)
Set rngName = .Find(Name, After:=.Cells(.Cells.Count), _
LookIn:=xlValues, lookat:=xlWhole)
End With
If rngName Is Nothing Then
Find_Column = "#N/A"
Else ' Calculate Name Column Letter.
Find_Column = Split(rngName.Address, "$")(1)
End If
End Function
I have more than 200 workbooks in an Folder, and i deletes the empty rows by giving an Range in the code that is Set rng = sht.Range("C3:C50000").
If Column C any cell is empty then delete entire Row. Day by day data is enhancing and below code took nearly half hour to complete the processing. That time limit is also increasing with the data.
I am looking for a way to to do this in couple of minutes or in less time. I hope to get some help.
Sub Doit()
Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Application.ScreenUpdating = FALSE
Application.DisplayAlerts = FALSE
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
Beep
Exit Sub
End If
xFileName = Dir(xFdItem & "*.xlsx")
Do While xFileName <> ""
Set wbk = Workbooks.Open(xFdItem & xFileName)
For Each sht In wbk.Sheets
Dim rng As Range
Dim i As Long
Set rng = sht.Range("C3:C5000")
With rng
'Loop through all cells of the range
'Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
'Since cell Is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
Next sht
wbk.Close SaveChanges:=True
xFileName = Dir
Loop
Application.ScreenUpdating = TRUE
Application.DisplayAlerts = TRUE
End Sub
This is how I would implement my suggestions of
collecting the rows to delete into a single range and deleting after the loop.
opening the workbooks in a hidden window so the user is not disturbed by files opening and closing. (And also a minor speed boost when opening files)
Dynamically defining your search range to fit the data of each file, eliminating wasted time searching blank ranges.
Sub Doit()
Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Dim xlApp As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
Beep
Exit Sub
End If
xFileName = Dir(xFdItem & "*.xlsx")
Set xlApp = CreateObject("Excel.Application." & CLng(Application.Version))
Do While xFileName <> ""
Set wbk = xlApp.Workbooks.Open(xFdItem & xFileName)
For Each sht In wbk.Sheets
Dim rng As Range
Dim rngToDelete As Range
Dim i As Long
Dim LastRow as Long
LastRow = sht.Cells.Find("*", SearchDirection:=xlPrevious).Row
Set rng = sht.Range("C3:C" & LastRow)
With rng
'Loop through all cells of the range
'Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
'Since cell Is empty, delete the whole row
If rngToDelete Is Nothing Then
Set rngToDelete = .Item(i)
Else
Set rngToDelte = Union(rngToDelete, .Item(i))
End If
End If
Next i
End With
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
Next sht
wbk.Close SaveChanges:=True
xFileName = Dir
Loop
xlApp.Quit
Set xlApp = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I use CreateObject to create a new excel app, and I use Application.Version so the new excel app is the same as the current one. I have had bad experience using New Excel.Application to create the object because it sometimes gets redirected to an excel 365 demo, or some other version of excel that is installed on the computer but not intended for use.
Try this for quicker row deletion:
Sub Doit()
Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Application.ScreenUpdating = FALSE
Application.DisplayAlerts = FALSE
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
Beep
Exit Sub
End If
xFileName = Dir(xFdItem & "*.xlsx")
Do While xFileName <> ""
Set wbk = Workbooks.Open(xFdItem & xFileName)
For Each sht In wbk.WorkSheets 'Sheets includes chart sheets...
On Error Resume Next 'in case of no blanks
sht.Range("C3:C5000").specialcells(xlcelltypeblanks).entirerow.delete
On Error Goto 0
Next sht
wbk.Close SaveChanges:=True
xFileName = Dir()
Loop
Application.ScreenUpdating = TRUE
Application.DisplayAlerts = TRUE
End Sub
Note though your biggest time sink may still be opening and saving/closing all the files.
Reference Filtered Column
The Function
Option Explicit
Function RefFilteredColumn( _
ByVal ColumnRange As Range, _
ByVal Criteria As String) _
As Range
Const ProcName As String = "RefFilteredColumn"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = ColumnRange.Worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim crg As Range: Set crg = ColumnRange.Columns(1)
Dim cdrg As Range: Set cdrg = crg.Resize(crg.Rows.Count - 1).Offset(1)
crg.AutoFilter 1, Criteria, xlFilterValues
On Error Resume Next
Set RefFilteredColumn = cdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError
ws.AutoFilterMode = False
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Use in Your Code
For Each sht In wbk.Worksheets
' The header row ('C2', not 'C3') is needed when using 'AutoFilter'.
Dim rng As Range: Set rng = sht.Range("C2:C5000")
Dim frg As Range: Set frg = RefFilteredColumn(rng, "")
If Not frg Is Nothing Then
frg.EntireRow.Delete
Set frg = Nothing
' Else ' no blanks
End If
Next sht
I have some tables from Excel that will be updated every month or so, what I am trying to do is to copy and paste those ranges from a "master workbook" to some several sheets. The way this works is I have 20 plus workbooks with those ranges "tables" already there, but I am having to manually open those workbooks then copy and paste the new values from the master workbook and close it.
Sub openwb()
Dim wkbk As Workbook
Dim NewFile As Variant
Dim ws As Worksheet
Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
Dim StrFile As Variant
Dim wb2 As Excel.Workbook
Application.DisplayAlerts = True
Application.ScreenUpdating = True
StrFile = Dir("C:\temp\*.xlsx*")
Do While Len(StrFile) > 0
Set wb = Workbooks.Open(StrFile)
'NewFile = Application.GetOpenFilename("microsoft excel files (*.xl*), *.xl*")
'
'If NewFile <> False Then
'Set wkbk = Workbooks.Open(NewFile)
'''**********************
strSearch = "Descitption"
Set ws = Worksheets("TestCases")
With ws
Set aCell = .Columns(4).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bcell = aCell
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Do
Set aCell = .Columns(4).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bcell.Address Then Exit Do
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
'~~> I am pasting to Output sheet. Change as applicable
Set wb2 = Workbooks.Open("C:\temp\Bulk tool\test1.xlsm")
If Not rngCopy Is Nothing Then rngCopy.Copy 'paste to another worksheet Sheets("Output").Rows(1)
End With
'**************************
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
StrFile = Dir
Loop
End Sub
The range is dynamic, it can change from 2 rows to 20, but to give an example A1:K20 and it will go to the same range to another workbook.
first off let me thank everyone helping me on this.
here is what I have so far (see code)
when I run it I am getting error 1004 not sure what I changed but it was working fine, also what I am trying to do, is to copy to another worksheet.
Copying and pasting values in a worksheet uses the Range.Copy and Range.PasteSpecial.
An example code is as follows:
Sub CopyThis()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Sht1.Range("A1:D4").Copy
Sht2.Range("A1:D4").PasteSpecial xlPasteAll
End Sub
Alternatively, you can also loop through values. I usually do this out of preference because I often do "If Then" in loops
Sub CopyThis2()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Dim i As Long, j As Long
For i = 1 To 4
For j = 1 To 4
Sht2.Cells(i, j).Value = Sht1.Cells(i, j).Value
Next j
Next i
End Sub
Perhaps you can do little tricks with coding to make it faster. Like in this Answer below
Looping through files in a Folder
You can Also use Application.Screenupdating = False before the loop & True after the loop, so that your process would be way faster. In the Loop you can put the Code suggested by Parker.R ....
Also, there is no other way to copy data from workbooks without opening them in VBA.All you can do it play with the way files are being opened and closed so that the process becomes faster.
Other than Screenupdating few more properties you can Set As per this Link
Code to loop Using FSO
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder, sfol As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getFolder(f_add) ''''f_add is the Address of the folder
'''' Loop For Files in That Folder
For Each objFile In objFolder.Files
''''Your Code
Next
'''' Loop for All the Subfolders in The Folder
For Each sfol In objFolder.subfolders
''' Your Code Here
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
I'm writing a script that copies from cells to test file (.sql)
Everytime I create a new file the resulte is in doublequotes, and it's unacceptable, because it has to be an SQL script and with quotes it wouldn't work.
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Sheets("TU").Columns(10).Copy
Sheets("TU").Columns(11).PasteSpecial xlPasteValues
On Error Resume Next
Set WorkRng = Range("K3:K20")
Set wb = Application.Workbooks.Add
WorkRng.Copy
wb.Worksheets(1).Paste
saveFile = Application.GetSaveAsFilename(fileFilter:="Text Files (*.sql), *.sql")
wb.SaveAs Filename:=saveFile, FileFormat:=xlTextWindows, CreateBackup:=False
wb.Close
End Sub
Any ideas?
Checked this and this doesn't show as in single quotes for me. Do the original values of each cell contain single quotes?
If that is the case then you can try a Loop on the cells and replace each quote after you paste the values into column K.
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Dim cell As Range, rng As Range
Set rng = Range("K:K")
Sheets("TU").Columns(10).Copy
Sheets("TU").Columns(11).PasteSpecial xlPasteValues
For Each cell In rng
If cell.Value = "" Then
Exit For
End If
If InStr(1, cell.Value, "'") > 0 Then
cell.Value = Replace(cell.Value, "'", "")
End If
Next cell
On Error Resume Next
Set WorkRng = Range("K3:K20")
Set wb = Application.Workbooks.Add
WorkRng.Copy
wb.Worksheets(1).Paste
saveFile = Application.GetSaveAsFilename(fileFilter:="Text Files (*.sql), *.sql")
wb.SaveAs Filename:=saveFile, FileFormat:=xlTextWindows, CreateBackup:=False
wb.Close
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.)