See listboxI have created a userform with a list box that I can search and filter. After I have searched for specific information, I want to print the information out. My idea is to copy and paste the information from the list box on to another sheet, & then print that sheet out. However I am not getting the code right...
Please help....
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim shPrint As Worksheet
Dim t As Long
Dim i As Long
Dim x As Long
Set shPrint = ThisWorkbook.Sheets("Print")
t = shPrint.Range("H10000").End(xlUp).Row
shPrint.Range("A" & 2, "H" & t + 1).ClearContents
For i = 1 To PatientDetails.ListDatabase1.ListCount - 1
For x = 0 To 8
shPrint.Cells(i + 1, x) = PatientDetails.ListDatabase1.List(i, x)
Next x
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
If you need any additional information, please let me know!
See Userform
Related
I'm looking for a way or method to copy (adding new) columns between sheets.
Let me illustrate:
Sheet: template
Sheet: student
Initially I duplicate "Template" and rename it.
But when additional tasks are added to "Template" I want to update "Student" minding that I have already changed the content in range B2:D4. So copy/pasting the whole range is not an option.
What's the best way to go about this?
First checking if row A in the destination sheet has a value, if not copy/paste that column?
A push in the right direction (or some code to get started on) would be very much appreciated.
You can achieve this by looping true columns headers, given they are in the first row and all tabs are named appropriately:
Sub AddTask()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.DisplayStatusBar = True
End With
Dim wb As Workbook: Set wb = ThisWorkbook
With wb
Dim LastTemplateCol As Long: LastTemplateCol = .Worksheets("Template").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To LastTemplateCol
Dim TempTask As String: TempTask = .Worksheets("Template").Cells(1, i).Value
Dim LastStudentCol As Long: LastStudentCol = .Worksheets("Student").Cells(1, Columns.Count).End(xlToLeft).Column
For t = 2 To LastStudentCol
Dim StudTask As String: StudTask = .Worksheets("Student").Cells(1, t).Value
Dim Exists As Boolean: Exists = False
If TempTask = StudTask Then
Exists = True
GoTo taskloop:
Else
GoTo studloop:
End If
studloop:
Next t
If Exists = False Then
.Worksheets("Template").Cells(1, i).Columns.EntireColumn.Copy
.Worksheets("Student").Cells(1, LastStudentCol + 1).PasteSpecial
End If
taskloop:
Next i
End With
Application.CutCopyMode = False
End Sub
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 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.
Application.ScreenUpdating = False
Dim r As Range
Dim a As Long
Set op = Worksheets("ZVCTOSTATUS")
Set CP = op.Columns("J")
Set CTO = op.Range("J1")
Set OD = op.Columns("G")
Set ZV = op.Columns("H")
op.Activate
fa = op.Range("J" & Rows.Count).End(xlUp).Row
Set r = op.Range("J2:J" & fa)
For Each C In r
CTO = CP.Cells(C.Row, 1).Value
If CTO = "FG BOOKED" Or CTO = "CLOSED" Then
ZV.Cells(C.Row, 1) = 0
ElseIf CTO = "NOT STARTED" Or CTO = "UNCONFIRMED" Then
ZV.Cells(C.Row, 1) = OD.Cells(C.Row, 1).Value
End If
Next C
I am using this code to go through my worksheet making a For loop to change value in Column H by referencing to Column J.
When this code is used on a standalone worksheet, it seems to work perfectly. But once I port it over to a much bigger file which has data connection, and I run this macro only individually, it causes my CPU to run at 100% and takes up to 10 minutes.
Does anyone know why this is happening?
To help your macro run smoother you can insert the below code before your main code (just below the sub) and right after your code (just before the end sub)
This will turn off screen updates, alerts, and set the calculation to manual so no formulas are updating until after the process has ran.
'Please Before Main Code'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
'Insert main code here'
'Place After Main code'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
It seems you fell in a trap which has the following features:
You are using a large excel file which is several MB in size
The excel document is full of formula and data connection
Additionally it might have pivot tables and charts
Calculation option for Formula is Automatic
Try this:
1. Go to formula tab
2. Click "Calculation Option"
3. Select "Manual"
Now execute the macro you have created. It should be good to go. Once the macro is executed. You can change the calculation option.
Note: You can control the calculation option problematically as well using below snippet:
Dim CalcMode As Long
' This will set the calculation mode to manual
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
<< Add your macro processing here >>
' Again switch back to the original calculation option
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
Excel tries to calculate the values (based on formula) everytime any cell is changed. This is done for the entire document for every cell updated by your macro. So, for large excel document, it causes high CPU consumption.
You are setting values of cells one at a time triggering a recalculation. The way to do this correctly is to read the columns into memory first, set the values and write the results with one operation.
Public Sub AnswerPost()
Dim r_status As Range, r_value As Range, r_calc As Range
Dim i As Long, n As Long
Dim op As Worksheet
Set op = Worksheets("ZVCTOSTATUS")
' Find the number of items on cell "J2" and below
n = Range(op.Range("J2"), op.Range("J2").End(xlDown)).Rows.Count
' Set the n×1 range of cells under "J", "G" and "H" columns
Set r_status = op.Range("J2").Resize(n, 1)
Set r_value = op.Range("G2").Resize(n, 1)
Set r_calc = op.Range("H2").Resize(n, 1)
Dim x_status() As Variant, x_value() As Variant, x_calc() As Variant
' Read cells from the worksheet into memory arrays
x_status = r_status.Value2
x_value = r_value.Value2
x_calc = r_status.Value2
' Set values of x_calc based on x_status, row by row.
For i = 1 To n
Select Case x_status(i, 1)
Case "FG BOOKED", "CLOSED"
x_calc(i, 1) = 0#
Case "NOT STARTED", "UNCONFIRMED"
x_calc(i, 1) = x_value(i, 1)
End Select
Next i
' Write the resulting array back into the worksheet
r_calc.Value2 = x_calc
End Sub
Test case for above code
Can anyone tell me how to improve this macro?
All the macro does is it just reads an Excel file for a list a accounts to update in an application (SmarTerm Beta). It technically already accomplishes the goal, but is there a way to code it so that while it’s reading the Excel file, the coordinates of the cells from which to read the account numbers and also the coordinates of the cells in which to write an output don’t depend on a "pre-selected" a cell? The risk with selecting a cell is that if someone were to accidentally select a different cell while the macro is running, everything will get screwed up.
Here's my current code:
Public oExcelObj As Object
Function WaitSystem(Optional NoDialog as Variant) As Boolean
Dim nContinue as Integer
Dim nTimeOut as Integer 'In seconds.
'The default timeout for each command is 3 minutes.
'Increase this value if your host requires more time
'for each command.
nTimeOut = 10
If IsMissing(NoDialog) then NoDialog = False
'Wait for response from host.
Session.EventWait.Timeout = nTimeOut
Session.EventWait.EventType = smlPAGERECEIVED
Session.EventWait.MaxEventCount = 1
WaitSystem = True
If Session.EventWait.Start = smlWAITTIMEOUT Then
If NoDialog Then
WaitSystem = False
Else
nContinue = QuerySyncError()
If nContinue <> ebYes then WaitSystem = False
End If
End If
Set LockStep = Nothing
End Function
'Establish link. Search for Excel.
Function OleLinkConnection
Const XlMaximized = &HFFFFEFD7
Titlebar$ = AppFind$("Microsoft Excel")
If Titlebar$ <> "" Then
bIsExcelActive = True
If AppGetState(Titlebar$) = ebMinimized Then
AppSetState 2, Titlebar$
End If
Else
bIsExcelActive = False
End If
If bIsExcelActive Then
'Create Excel Object using current instance of Excel.
Set oExcelObj = GetObject(, "Excel.Application")
Else
'Create Excel Object using a new instance of Excel.
Set oExcelObj = CreateObject("Excel.Application")
End If
Version = oExcelObj.Application.Version
oExcelObj.ScreenUpdating = True
oExcelObj.Displayalerts = True
oExcelObj.Visible = true
End Function
Sub JPBmacro
Dim AccountNumber As String
Dim Temp As Integer
Begin Dialog StartDialogTemplate ,,211,74,"Run JPBmacro?"
OKButton 60,12,92,20,.Proceed
CancelButton 60,40,92,20,.Exit
End Dialog
Dim StartDialog As StartDialogTemplate
r% = Dialog(StartDialog)
If r% = 0 Then End
g$ = "G:\DATA\outputfile.xlsx"
oleCode = OleLinkConnection
oExcelObj.Workbooks.Open g$
oExcelObj.Range("A1").Select ‘<----This selects the cell from which all coordinates are based off of. The coordinates of oExcelObj.ActiveCell.Offset(Y,X).Value VBA depend on selecting a cell.
NEXTACCOUNT:
Temp = 0
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
While AccountNumber <> ""
Session.SendKey "CLEAR"
If WaitSystem = False Then End
Session.Send "ACTU " & AccountNumber
Session.SendKey "ENTER"
If WaitSystem = False Then End
If Trim(Session.ScreenText(4,6,1,22)) = "INVALID ACCOUNT NUMBER" Or Trim(Session.ScreenText(4,6,1,19)) = "ACCOUNT NOT ON FILE" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(4,6,1,22))
GoTo RESTARTLOOP
End If
UPDATEIOV:
If Trim(Session.ScreenText(13,76,1,1)) = "Y" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = "Account already flagged as institutional."
Else
Session.Row = 13
Session.Column = 76
Session.send "Y"
Session.SendKey "ENTER"
If WaitSystem = False Then End
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(24,2,1,50))
End If
RESTARTLOOP:
Temp = Temp + 1
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
Wend
ENDNOW:
oExcelObj.Workbooks.Close
MsgBox "All Done!"
End Sub
Why not keep the reference to the first cell?
Dim rng as Range
Set rng = oExcelObj.Range("A1")
i=1
...
x = rng.Cell(i,1).Value
'Or faster yet is reading all the values into an variant array.
Dim array() as Variant
array = rng.Resize(N,M).Value
' Work with array as
x = array(i,1)
Given the comment from assylias and that another poster has since "answered" with this approach:
I can't see where oExcelObj is instantiated? Or how you are referring to a specific sheet.
Regardless of which,
you can avoid select by setting a range, ie Set rng1 = oExcelObj.Sheets(1).Range("A1")
and then use offsets from rng1.
The user won't be able to interfere while the code is running