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
Related
I'm trying to create a new sheet labeled with a different identifier from a range and also have two cells from other ranges included on each update. I can get the new sheets to create with a different label from a range, and have the first cell in the second range (xRg2) added to each subsequent sheet, but haven't been successful at iterating through the second range. I know I need another loop somewhere but my last nest created way too many sheet. See example below
Sub Add()
Dim xRg As Excel.Range
Dim xRg2 As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Dim wSh2 As Excel.Worksheet
Dim wSh3 As Excel.Worksheet
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Set wSh2 = ThisWorkbook.Sheets("List")
Set wSh3 = ThisWorkbook.Sheets("Template")
Set xRg2 = wSh2.Range("G66:G88")
Application.ScreenUpdating = False
For Each xRg In wSh2.Range("B66:B88")
With wBk
wSh3.Copy after:=.Sheets(.Sheets.Count)
On Error Resume Next
wSh.Name = xRg.Value
wSh.Cells(33,7) = xRg2.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & "already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True End Sub
So, to summarize, the goal here is to input the ranges into the code each time and have each new sheet include the first values from each range, then the second sheet the second values from each range, and so on until the xRg is at the end of it's list. I know there's only two ranges down here but the total will be 3. Also apologies on the poor variable discipline...
Thanks!
Try something like this (sorry do not like all those x... variable names)
Sub Add()
Dim c As Range
Dim wb As Workbook, ws As Worksheet, wsList As Worksheet
Set wb = ActiveWorkbook
Set wsList = wb.Worksheets("List")
Application.ScreenUpdating = False
For Each c In wsList.Range("B66:B88").Cells
ThisWorkbook.Sheets("Template").Copy after:=wb.Sheets(wb.Sheets.Count)
Set ws = wb.Sheets(wb.Sheets.Count) '<< get the just-created sheet copy
On Error Resume Next
ws.Name = c.Value
ws.Cells(33, 7) = c.EntireRow.Columns("G").Value
If Err.Number = 1004 Then
Debug.Print "'" & c.Value & "' already used as a sheet name"
End If
On Error GoTo 0
Next c
Application.ScreenUpdating = True
End Sub
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
I have a master workbook, which houses a group of 15 worksheets that house data for summary pivot tables and whatnot. Every week this master workbook gets updated with a daily report that has those 15 worksheets, but also around 20 other ones. I am just trying to get a script together to identify if they exist, and if so, to move that daily data to the master workbooks worksheet (only move data if daily wb worksheet exists in master workbook).
Here is a very general shell of what I'm trying to achieve, but I'm not well versed in determining the logic if a sheet exists, so my blnFound variable is obviously misplaced. I hope this shows a rough outline of what I'm trying to achieve. Any help is greatly appreciated!
Option Explicit
Sub Update_New_Data()
Const BasePath As String = "C:\\User\Data..."
Dim wbMaster As Workbook: Set wbMaster = ThisWorkbook
Dim wbNewData As Workbook: Set wbNewData = Workbooks.Open(BasePath & "\03.01.20.xlsx")
Dim wsMaster As Sheet
Dim blnFound As Boolean
'places all sheet names into array
With wbNewData
Dim varWsName As Variant
Dim i As Long
Dim ws As Worksheet
ReDim varWsName(1 To wbNewData.Worksheets.Count - 2)
For Each ws In wbNewData.Worksheets
Select Case ws.Name
Case "Inputs", "Data --->>>"
Case Else
i = i + 1
varWsName(i) = ws.Name
End Select
Next
End With
'if wbNewData sheet name is found in wbMaster
'then locate it and place wbNewData data into that sheet
With wbMaster
For Each wsMaster In wbMaster.Sheets
With wsMaster
If .Name = varWsName(i) Then
blnFound = True
wbNewData(Worksheets(i)).UsedRange.Copy Destination:=wbMaster(Worksheets(i)).Range("A1")
Else: blnFound = False
End If
End With
Next
End With
End Sub
To check if something exists you can use a Dictionary Object
Option Explicit
Sub Update_New_Data()
Const BasePath As String = "C:\\User\Data..."
Dim wbMaster As Workbook, wbNewData As Workbook
Set wbMaster = ThisWorkbook
Set wbNewData = Workbooks.Open(BasePath & "\03.01.20.xlsx", , False) ' read only
Dim ws As Worksheet, sKey As String, rng As Range, msg As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'places all master sheet names into dictionary
For Each ws In wbMaster.Sheets
If ws.Name = "inputs" Or ws.Name = "Data --->>>" Then
' skip
Else
dict.Add CStr(ws.Name), ws.Index
Debug.Print "Added to dict", ws.Index, ws.Name
End If
Next
' if wbNewData sheet name is found in wbMaster
' then locate it and place wbNewData data into that sheet
For Each ws In wbNewData.Sheets
sKey = CStr(ws.Name)
If dict.exists(sKey) Then
' clear master
wbMaster.Sheets(dict(sKey)).cells.clear
Set rng = ws.UsedRange
rng.Copy wbMaster.Sheets(dict(sKey)).Range("A1")
msg = msg & vbCr & ws.Name
Else
Debug.Print "Not found in master", ws.Index, ws.Name
End If
Next
wbNewData.Close
' result
If Len(msg) > 0 Then
MsgBox "Sheets copied were " & msg, vbInformation
Else
MsgBox "No sheets copied", vbExclamation
End If
End Sub
[table - worksheet "output - flat"][1]
I have code below that checks to see if column "NamedRange" in the table attached appears as a named range in the (dstRng) template and if it does exist it returns the value to the right ("report balance"). How can I add a condition where when the user chooses a template it will only return values based on the Ted ID - in the table attached. I have 2 templates and it loops through the two templates however I want the first template to only return values for Ted ID 10004 and template 2 it will only return values for Ted ID 11372 and etc. etc. Hope that makes sense... let me know if u have any questions
Option Explicit
Sub Button4_Click()
Dim Desktop As Variant
Dim Files As Object
Dim Folder As Variant
Dim oShell As Object
Dim Tmplts As Variant ' Templates folder
Dim wsLocal As Worksheet
Dim wsGroup As Worksheet
Dim wb As Object
' Check Box 2 "Select All" must be checked to run the macro.
If ActiveSheet.Shapes("Check Box 2").ControlFormat.Value = xlOff Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
' Prompt user to locate the Templates folder.
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Tmplts = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set oShell = CreateObject("Shell.Application")
Set Desktop = oShell.Namespace(0)
' Create the Output folder on the User's Desktop if it does not exist.
Set Folder = Desktop.ParseName("Output")
If Folder Is Nothing Then
Desktop.NewFolder "Output"
Set Folder = Desktop.ParseName("Output")
End If
Set Files = oShell.Namespace(Tmplts).Items
Files.Filter 64, "*.xlsm"
For Each wb In Files
Set wb = Workbooks.Open(Filename:=wb.Path, UpdateLinks:=False)
Call BreakLinks(wb)
On Error Resume Next
Set wsLocal = wb.Worksheets("RVP Local GAAP")
Set wsGroup = wb.Worksheets("RVP Group GAAP")
'unprotect workbook
wsLocal.Unprotect Password:="KqtgH5rn9v"
wsGroup.Unprotect Password:="KqtgH5rn9v"
On Error GoTo 0
' Check that both worksheets exist before updating.
If Not wsLocal Is Nothing And Not wsGroup Is Nothing Then
Call ProcessNamedRanges(wb)
'lock the workbook
wsLocal.Protect Password:="KqtgH5rn9v"
wsGroup.Protect Password:="KqtgH5rn9v"
''MsgBox "Ranges have been updated sucessfully."
' Save the workbook to the folder and close.
On Error Resume Next
wb.SaveAs Filename:=Folder.Path & "\" & wb.Name
ActiveWorkbook.Close True
On Error GoTo 0
End If
Next wb
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub ProcessNamedRanges(ByRef wb As Workbook)
Dim dstRng As Range
Dim rng As Range
Dim rngName As Range
Dim rngNames As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Output - Flat")
' Exit if there are no named ranges listed.
If wks.Range("D4") = "" Then Exit Sub
Set rngNames = wks.Range("D4").CurrentRegion
Set rngNames = Intersect(rngNames.Offset(1, 0), rngNames.Columns(2))
'Loop through all the values in NamedRange
For Each rngName In rngNames
' Verify the Named Range exists.
On Error Resume Next
Set dstRng = wb.Names(rngName.Text).RefersToRange
If Err = 0 Then
'Copy the report balance to the Template worksheet in column "G".
dstRng.Value = rngName.Offset(0, 1).Value
Else
'answer = MsgBox("The Named Range """ & rngName.Value & """ Does Not Exist" & vbLf & vbLf & "Continue?", vbYesNo + vbExclamation)
'If answer = vbNo Then Exit Sub
End If
On Error GoTo 0
Next rngName
End Sub
Sub BreakLinks(ByRef wb As Workbook)
Dim i As Long
Dim wbLinks As Variant
wbLinks = wb.LinkSources(xlExcelLinks)
If Not IsEmpty(wbLinks) Then
For i = 1 To UBound(wbLinks)
ActiveWorkbook.BreakLink wbLinks(i), xlLinkTypeExcelLinks
Next i
End If
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.)