i just like to open several source files (all excel) and always copy the complete data rom sheet 1 into my target-sheet. First part works well.
The unusual thing is that i want the tables to be merged from the left to right (horizontical), not from top down.
Of course the range needs to adjust dynamically. The allocation part is also working. Whats not working is to copy it over my target sheet and always add from left to right.
Means
Worksheet 1 hast data from A1:C10
Worksheet 2 has data from A1:B20
should be merged like
Worksheet 1 hast data from A1:C10 -> A1:C10
Worksheet 2 has data from A1:B20 -> D1:E20
etc. I cannot do this. It either gives me a 1004, or says that the object doesnt support the method.
Here's the code:
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
Set oTargetSheet = ActiveWorkbook.Sheets.Add
lErgebnisSpalte = 1
sPfad = "C:\Users\TEST\"
sDatei = Dir(CStr(sPfad & "*.xl*"))
Do While sDatei <> ""
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True)
z1 = oSourceBook.Sheets(1).UsedRange.Rows.Count
s1 = oSourceBook.Sheets(1).UsedRange.Columns.Count
**oSourceBook.Sheets(1).Range(oSourceBook.Cells(1, 1), oSourceBook.Cells(z1, s1)).Copy oTargetSheet.Range(oTargetSheet.Cells(1, lErgebnisSpalte), oTargetSheet.Cells(z1, s1))**
lErgebnisSpalte = lErgebnisSpalte + 1
oSourceBook.Close False 'nicht speichern
'Next File
sDatei = Dir()
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub
Debug keeps saying:
Object doesnt support the method; and marks this line:
**oSourceBook.Sheets(1).Range(oSourceBook.Cells(1, 1), oSourceBook.Cells(z1, s1)).Copy oTargetSheet.Range(oTargetSheet.Cells(1, lErgebnisSpalte), oTargetSheet.Cells(z1, s1))**
This works for me (in this case I just copy the existing range into the next free column)
Private Sub Worksheet_Activate()
Dim colNr As Integer
For i = 1 To 100
colNr = ThisWorkbook.ActiveSheet.Range("A1").End(xlToRight).Column
colNr = colNr + 1
ThisWorkbook.ActiveSheet.Range("A1:B5").Copy Destination:=ThisWorkbook.ActiveSheet.Cells(1, colNr)
Next i
End Sub
I hope this helped.
Related
I wrote below script but get hung up on this part of the code:
If TargetWb.Sheets("Expenses").Range("F61").Offset(0, i - 1).Value = CVErr(xlErrNA) Then GoTo Skip Else GoTo Continue
What I'm trying to do: if the value of the cell returns #N/A as part of a function I would like to move to next loop. Any recommendation on how to accomplish this?
Thanks in advance for solutions. Also always open to recommendations on how to better structure this code, as I'm still a beginner.
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Dim S_Deal As Range
Dim i As Integer
'SourceWb - Workbook were data is copied from
'TargetWb - Workbook were data is copied to and links are stored
Application.ScreenUpdating = False
Set TargetWb = ThisWorkbook
filePath = ThisWorkbook.Sheets("Expenses").Range("S4").Value
Set SourceWb = Workbooks.Open(filePath)
For i = 1 To 6
If TargetWb.Sheets("Expenses").Range("F61").Offset(0, i - 1).Value = CVErr(xlErrNA) Then GoTo Skip Else GoTo Continue
Continue:
Set S_Deal = TargetWb.Sheets("Expenses").Cells(11, 5 + i)
SourceWb.ActiveSheet.Range("OPEX_Control").Value = S_Deal.Value
TargetWb.Sheets("Expenses").Range("F12:F15").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("P9:P12").Value
TargetWb.Sheets("Expenses").Range("F18:F21").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("o14:o17").Value
TargetWb.Sheets("Expenses").Range("F23:F26").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("o19:o22").Value
TargetWb.Sheets("Expenses").Range("F29").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("o25").Value
Skip:
Next i
Application.ScreenUpdating = True
End Sub
If you want to check whether the excel function return #N/A in vba, you can use the following code:
If Application.WorksheetFunction.IsNA(Cells(intRow, x)) Then
Since what you want is the execute a code unless the the wb.function is not #N/A, by re-arrange your If VBA code should be able to achieve your desired outcome.
If Application.WorksheetFunction.IsNA(TargetWb.Sheets("Expenses").Range("F61")) = false then
{your code}
end if
next i
So when the wb function return #N/A, it will not execute the code in between and go to next loop
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I have a PowerApp which updates a cell in an Excel file hosted in OneDrive. The Excel file contains a macro that is supposed to run when the PowerApp changes the Excel file. However, it doesn't do that. If I update a cell manually, the macro works just fine. It's just not activated when the file is updated by PowerApps.
Is there a different function I can use that will be triggered when PowerApp changes the file?
If that is not possible, could I use a Flow to activate the macro?
Here is the current script that works with manual changes, but not the automatic PowerApps changes.
Private Sub Worksheet_Change(ByVal Target As Range)
Call InsertImageTest
End Sub
Here is the macro that I want to trigger using the code above.
Sub InsertImageTest()
' This macro inserts an image from a set location to a set cell.
Dim ws As Worksheet
Dim imagePath As String
Dim cell As String
Dim posText As String
Dim imgLeft As Double
Dim imgTop As Double
Dim rngX As Range
Dim activeSheetName As String
' Customizable variables
imagePath = ActiveWorkbook.Path & Range("$B$2").Value
posText = "Signature"
activeSheetName = "Data" ' Set to "Data" by default, but will change to the Active sheets name, if the active sheet is not called "Data"
' For i = 1 To Sheets.Count
' If CStr(Sheets(i).Name) Is CStr(activeSheetName) Then
' Debug.Print "Code can be executed! Data tab was found"
' End If
' Next i
cell = "$A$1"
Set ws = ActiveSheet
Set rngX = Worksheets(activeSheetName).Range("A1:Z1000").Find(posText, lookat:=xlPart)
If Not rngX Is Nothing Then
cell = rngX.Address
Debug.Print cell
Debug.Print rngX.Address & " cheating"
Worksheets(activeSheetName).Range(cell).Value = ""
Debug.Print rngX.Address & " real"
imgLeft = Range(cell).Left
imgTop = Range(cell).Top
' Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=imgLeft, _
Top:=imgTop, _
Width:=-1, _
Height:=-1
End If
' The code beaneath will resize the cell to fit the picture
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub
Unfortunately the server opens Excel through APIs and Excel doesn't fire macros in this way. It seems flow has the same. I would consider implement the macro function logic in PowerApps. Customize the edit form of the column which supposes to trigger the macro, depends what the macro should do. Possibly unlock a data card if the macro trys to alter a value of another column.
Similar versions of this question probably have been asked before, but I had questions regarding this issue.
Basically for my function, I just want to run simple a spell check on selected tables from Microsoft Access. Since Access doesn't support individual highlighting all too well in reports, I have the data exported to an Excel file and have VBA run tests for any errors there. After searching online for tips, I have the current code to run faster than what I originally had. But ideally no matter the size of the table I want the function to run under 10 minutes. But currently for some of them, for tables that have 500k+ cells the runtime can still go past 30 minutes. So I was wondering if anything further can be done to better enhance the runtime of this.
Private Function Excel_Parser(outFile As String, errorCount As Integer, ByVal tName As String)
' EXCEL SETUP VARIABLES
Dim OpenApp As Excel.Application
Set OpenApp = CreateObject("Excel.Application")
Dim parserBook As Excel.Workbook
Dim parserSheet As Excel.Worksheet
' Opening exported file
Set parserBook = OpenApp.Workbooks.Open(outFile, , , , , , , , , , , , , , XlCorruptLoad.xlRepairFile)
If parserBook Is Nothing Then
status2 = "Failed to set Workbook"
Exit Function
Else
status3 = "Searching [" & tName & "] for errors"
Set parserSheet = parserBook.Worksheets(1)
' --------------------------------------------------------------------------------
' Fetch Table information
lastCellAddress = parserSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Address
Dim rng As Range
Set rng = parserSheet.Range("A1:" & lastCellAddress)
' --------------------------------------------------------------------------------
' Populating entire table data from Excel into array to save runtime.
Dim dataArr() As Variant, R As Long, C As Long
dataArr = rng.Value2
' Parsing through table data array
nRows = UBound(dataArr, 1)
nCols = UBound(dataArr, 2)
fileOuterLoop1 = Time
For R = 1 To nRows
For C = 1 To nCols
cCell = CStr(dataArr(R, C))
status4 = "Now running check on cell: [" & cCell & "]"
If cCell <> "" Or Not (IsNull(cCell)) Then
If Not OpenApp.Application.CheckSpelling(cCell) Then
errorCount = errorCount + 1
' Change cell status
vArr = Split(parserSheet.Cells(1, C).Address(True, False), "$")
fCol = vArr(0)
xDef = fCol & R
parserSheet.Range(xDef).Interior.Color = RGB(255, 213, 124)
End If
End If 'End of cCell is null check
Next C
Next R
fileOuterLoop2 = Time
fCheck = Format(fileOuterLoop2 - fileOuterLoop1, "hh:mm:ss")
' --------------------------------------------------------------------------------
parserSheet.Columns.AutoFit
status7 = "Loop Finished. Runtime: " & fCheck
' Save and Cleanup
OpenApp.DisplayAlerts = False
parserBook.SaveAs FileName:=outFile, FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
parserBook.Saved = True
parserBook.Close SaveChanges:=False
OpenApp.DisplayAlerts = True
Set parserSheet = Nothing
Set parserBook = Nothing
Set OpenApp = Nothing
' Return errorCount for database
Excel_Parser = errorCount
End If
End Function
outFile is a PATH string, where file exists from a TransferSpreadsheet command. And "status" variables are just error log textboxes in the Access form. I have tried adding in both Access' and Excel's versions of ScreenUpdating or Echo but I found that these commands actually make my function runtime slightly slower.
Two things:
Do you use status4 somewhere in your code to show current state of work and just omitted it here in the sample? If so, think about not displaying it for every loop, but maybe only every 50 steps by using Mod operator.
See https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/mod-operator
You should avoid screen refreshs and more on every loop in Excel by setting this before the loop:
OpenApp.ScreenUpdating = False
OpenApp.EnableEvents = False
OpenApp.Calculation = Excel_XlCalculation.xlCalculationManual
And this after the loop:
OpenApp.ScreenUpdating = True
OpenApp.EnableEvents = True
OpenApp.Calculation = Excel_XlCalculation.xlCalculationAutomatic
It can end in a massive speed up. Give it a try.
How to obtain a list of named range exist in a specific worksheet that start with particular string (for example all named range that start with total) and grab the value? I am trying to do Sub Total and Grand Total of accommodation cost based on the date. I will assign an unique name for each Sub Total based on the Date group. Then, I have a button that need to be clicked when it finishes to calculate the Grand Total based on the Named Range that I've assigned uniquely to each Sub Total.
Below is the code I wrote to do the Grand Total:
Sub btnTotal()
Dim Total, LastRowNo As Long
LastRowNo = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
Total = 0
For Each N In ActiveWorkbook.Names
Total = Total + IntFlight.Range(N.Name).Value
Next N
IntFlight.Range("$P" & LastRowNo).Select
Selection.NumberFormat = "$* #,##0.00;$* (#,##0.00);$* ""-""??;#"
With Selection
.Font.Bold = True
End With
ActiveCell.FormulaR1C1 = Total
End Sub
Note: the IntFlight from "Total = Total + IntFlight.Range(N.Name).Value" is the name of my worksheet.
The only problem with above code, it will looking all named range exist in the workbook. I just need to find named range exist in one particular worksheet, which start with given string and the row number (total26: means Sub Total from row 26) and then grab the value to be sum-ed as Grand Total.
Any ideas how to do this? Been spending 2 days to find the answer.
Thanks heaps in advance.
EDIT 1 (Solution Provided by Charles Williams with help from belisarius):
This is what I have done with the code from Charles Williams:
Option Explicit
Option Compare Text
Sub btnIntFlightsGrandTotal()
Dim Total, LastRowNo As Long
LastRowNo = FindLastRowNo("International Flights")
Dim oNM As Name
Dim oSht As Worksheet
Dim strStartString As String
strStartString = "IntFlightsTotal"
Set oSht = Worksheets("International Flights")
For Each oNM In ActiveWorkbook.Names
If oNM.Name Like strStartString & "*" Then
If IsNameRefertoSheet(oSht, oNM) Then
Total = Total + Worksheets("International Flights").Range(oNM.Name).Value
End If
End If
Next oNM
IntFlights.Range("$P" & LastRowNo).Select
Selection.NumberFormat = "$* #,##0.00;$* (#,##0.00);$* ""-""??;#"
With Selection
.Font.Bold = True
End With
ActiveCell.FormulaR1C1 = Total
End Sub
Function FindLastRowNo(SheetName As String) As Long
Dim oSheet As Worksheet
Set oSheet = Worksheets(SheetName)
FindLastRowNo = oSheet.UsedRange.Row + oSheet.UsedRange.Rows.Count
End Function
Thank you all for your help. Now, I need to come up with my own version for this script.
Here is some code that checks if a Defined Name starts with a string and refers to a range within the used range of a given worksheet and workbook.
Option Explicit
Option Compare Text
Sub FindNames()
Dim oNM As Name
Dim oSht As Worksheet
Dim strStartString As String
strStartString = "Total"
Set oSht = Worksheets("TestSheet")
For Each oNM In ActiveWorkbook.Names
If oNM.Name Like strStartString & "*" Then
If IsNameRefertoSheet(oSht, oNM) Then
MsgBox oNM.Name
End If
End If
Next oNM
End Sub
Function IsNameRefertoSheet(oSht As Worksheet, oNM As Name) As Boolean
Dim oSheetRange As Range
IsNameRefertoSheet = False
On Error GoTo GoExit
If Not oSht Is Nothing Then
If Range(oNM.Name).Parent.Name = oSht.Name And _
Range(oNM.Name).Parent.Parent.Name = oSht.Parent.Name Then
Set oSheetRange = oSht.Range("A1").Resize(oSht.UsedRange.Row + oSht.UsedRange.Rows.Count - 1, oSht.UsedRange.Column + oSht.UsedRange.Columns.Count - 1)
If Not Intersect(Range(oNM.Name), oSheetRange) Is Nothing Then IsNameRefertoSheet = True
Set oSheetRange = Nothing
End If
End If
Exit Function
GoExit:
End Function
The following function will output all the names and their totals in your Workbook.
I think it is the basic block you need to get your code running.
Sub btnTotal()
For Each N In ActiveWorkbook.Names
MsgBox N.Name + " " + CStr(Application.WorksheetFunction.Sum(Range(N)))
Next N
End Sub
Edit
Answering your comment:
Define your names in this way:
Then (and only then) the following code works:
Sub btnTotal()
For Each N In ActiveSheet.Names
If (InStr(N.Name, "!Total") <> 0) Then
MsgBox N.Name + " " + CStr(Application.WorksheetFunction.Sum(Range(N)))
End If
Next N
End Sub
If you do not define the scope of the names correctly you need a lot of extra work in your code.
Edit
As you forgot to mention that you are still working with Excel 2003, here you will find an addin to manage name scoping in that version. See screen cap below
HTH