I have kind of a basic question. I want to copy rows from workbook "WB1" to workbook "WB" if a cell (i,4) has an exact known value. The code I have tried to write is not working, what can I do do make it work? Hope someone can help me :)
Private Sub CommandButton1_Click()
Dim i As Integer
For i = 8 To 300
If Workbooks("WB1").Worksheets("Commodity Action Plan").Cell(i,4).Value = "Zamet" Then Workbooks("WB1").Worksheets("Commodity Action Plan").EntireRow.Copy
Workbooks("WB2").Worksheets("Action plan").EntireRow.Paste
End If
Next i
End Sub
I copied and checked your code and it wouldn't compile due to a few errors..
Your If statement was on one line, when it should be
If ValueToEvaluate = true Then
'code to execute goes here
End If
or
If ValueToEvaluate = True Then 'code to execute goes here
If you have the full statement on one line then you don't need the End If.
2nd problem is that you are trying to get the entirerow property of a sheet,
Workbooks("WB1").Worksheets("Commodity Action Plan").EntireRow.Copy
this exists on a range object, so you probably wanted something like
Workbooks("WB1").Worksheets("Commodity Action Plan").Rows(i).EntireRow.Copy
Rather than using Paste you can specify a destination (range) as the second argument for the Copy function, which is easier and less prone to errors than the copy & paste 2 stage method.
Try something like:
Private Sub CommandButton1_Click()
Dim i As Long 'Change to long so we don't get an error past row 32767
Dim outRow as Long
Dim sourceWs As Worksheet, destWs As Worksheet
Set sourceWs = Workbooks("WB1").Worksheets("Commodity Action Plan")
Set destWs = Workbooks("WB2").Worksheets("Action plan")
outRow = 1
'For testing
'Set sourceWs = Sheet1
'Set destWs = Sheet2
For i = 8 To 300
If sourceWs.Cells(i, 4).Value = "Zamet" Then
sourceWs.Rows(i).EntireRow.Copy destWs.Rows(outRow)
outRow = outRow + 1
Application.CutCopyMode = False
End If
Next i
End Sub
Related
I'm learning VBA and I'm trying to create a workbook wherein in one sheet (sheet2) it would do the calculation then once the calculation is finished the items in sheet2, I would be able to press a commandbutton with the macro of copying the cells in the other sheet (sheet1). I am successful so far in copying over the data however every time the commandbutton is pressed, the error message
'Run-time error'1004': Application-defined or object-defined error'
would pop up. When the debug option is selected it points to line 4 & 5. I searched all over the internet regarding this issue and I haven't stumbled upon any situation like this. I've followed this https://www.youtube.com/watch?v=Z62yORhPr3Q and it's 5th method I'm running with. The code that I have is:
Private Sub CommandButton1_Click()
Dim Part As Range
For Each Part In Range(Range("Q4"), Range("Q4").End(xlDown))
Sheets("VStock").Range(Part.Value).Value = _
Sheets("Calc").Range(Part.Offset(0, 1).Value).Value
Next Part
End Sub
Any help would be appreciated
Thanks!
Suggestion not to loop the entire column and set the Ranges before the main task of "copy/paste".
In your case the ranges are set up incorrectly
Sheets("VStock").Range(Part.Value).Value = _
Sheets("Calc").Range(Part.Offset(0, 1).Value).Value
.Range should Look into the location of cells, example: .Range("Q4:Q144").Value
in your case, Range ends up with .Range(*theValue*).Value
Correct code Example:
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet: Set ws1 = Sheets("Calc")
Dim ws2 As Worksheet: Set ws2 = Sheets("VStock")
Dim SourceRange, dbRange As Range
Dim lRow as Long
lRow = ws1.Range("Q" & ws1.Rows.Count).End(xlUp).Row
If lRow <= 4 Then
MsgBox ("No data to copy")
Exit Sub
End If
Set SourceRange = ws1.Range("Q4:Q" & lRow) ' Calc
Set dbRange = ws2.Range("Q4:Q" & lRow) ' VStock
dbRange.Value = SourceRange.Offset(0, 1).Value
End Sub
this might be answered already from other posts I have read but still struggling to figure it out.
I have a workbook with 85 worksheets on it. Each sheet is like an invoice format, meaning it is not formatted as a normal data set. In order for me to get the data only I need, i created helper columns which only selects the data I need for consolidation. So I have a range I13:N42 which contains the data I need to consolidate.
At the end of the workbook, I already set up a Master Sheet with all the necessary headers for the data set. And there are 2 more worksheets namely "Tracking" & "AppControl" but I dont want them to be included in the loop together with the Master sheet.
For my range (filled with cell references/formulae), I need to copy only the row that has data in it.
You might have some ideas to improve the code I am currently using.
Sub Combine()
Dim i As Integer
Dim ws As Worksheet
Dim rng As Range
On Error Resume Next
For i = 1 To Sheets.Count
Sheets(i).Activate
Range("I13:N42").Select
Selection.Copy Destination:=Sheets("Master").Range("A65536").End(xlUp)(2)
Next i
End Sub
First remove On Error Resume Next. This line hides all error messages but the errors still occour, you just cannot see their messages. So if there are errors you cannot see you cannot fix them. If you don't fix them your code cannot work. Remove that line and fix your errors! Also see VBA Error Handling – A Complete Guide.
Second Avoid using Select in Excel VBA. That is a very bad practice and makes your code unreliable!
Option Explicit
Public Sub Combine()
Dim wsMaster As Worksheet ' set master worksheet
Set wsMaster = ThisWorkbook.Worksheets("Master")
Dim ExcludeWorksheets As Variant ' define worksheets names to exclude
ExcludeWorksheets = Array(wsMaster.Name, "Tracking", "AppControl")
Dim i As Long
For i = 1 To ThisWorkbook.Worksheets.Count
If Not IsInArray(ThisWorkbook.Worksheets(i).Name, ExcludeWorksheets) Then 'exclude these worksheets
ThisWorkbook.Worksheets(i).Range("I13:N42").Copy Destination:=wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)(2)
End If
Next i
End Sub
Public Function IsInArray(ByVal StringToBeFound As String, ByVal Arr As Variant) As Boolean
IsInArray = (UBound(Filter(Arr, StringToBeFound)) > -1)
End Function
Alternatively you can use a For Each loop which looks a bit cleaner then
Option Explicit
Public Sub Combine()
Dim wsMaster As Worksheet ' set master worksheet
Set wsMaster = ThisWorkbook.Worksheets("Master")
Dim ExcludeWorksheets As Variant ' define worksheets names to exclude
ExcludeWorksheets = Array(wsMaster.Name, "Tracking", "AppControl")
Dim ws As Worksheet
For Each ws Is ThisWorkbook.Worksheets
If Not IsInArray(ws.Name, ExcludeWorksheets) Then 'exclude these worksheets
ws.Range("I13:N42").Copy Destination:=wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)(2)
End If
Next ws
End Sub
Continuing the question:
TextBox object customisation - Compile error: Invalid or unqualified reference
I am going to copy this element - textbox into all worksheets throughout my document.
I would like to have it exactly in the same place in each worksheet.
For this purpose I used the code:
Sub Asbuildcopy()
Dim wsh As Worksheet
Dim ArraySheets As String
Dim x As Variant
For Each wsh In ActiveWorkbook.Worksheets
ActiveSheet.Shapes("Textbox 3").Copy
Application.Goto Sheets(ArraySheets).Range("Q6")
ActiveSheet.Paste
ArraySheets(x) = wsh.Name
x = x + 1
End Sub
According to the advice here:
https://www.ozgrid.com/forum/index.php?thread/73851-copy-shape-to-cell-on-another-worksheet/
https://i.stack.imgur.com/lOhJj.png
stating about copying an element into another sheet.
Apart from my code, one problem is the location of this element. I used target cell as Q6, but I would like to have it exactly in the same place as on the 1st (initial) sheet.
Thank you for your hint,
Try this. As per comment, can use the Top and Left properties of a shape to position it as per the first sheet.
Use more meaningful procedure and variable names for your actual code.
Sub x()
Dim ws As Worksheet, ws1 As Worksheet, s As Shape
Set ws1 = Worksheets("Sheet1") 'sheet containing original textbox
Set s = ws1.Shapes("TextBox 3") 'name of original textbox
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
s.Copy
ws.Paste
ws.Shapes(ws.Shapes.Count).Top = s.Top
ws.Shapes(ws.Shapes.Count).Left = s.Left
End If
Next ws
Application.ScreenUpdating = True
End Sub
I have a macro written that clears contents of the active cell row then calls a module to shift the remaining rows up. I am experiencing a long wait time for the macro to finish running. Not sure if this could be written better to execute quicker. The first module is called when a user clicks "Remove Client" on a User Form. Any help would be appreciated. Thank you!
'Called when user clicks Remove Client on User Form
Sub letsgo()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder")
ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents
Call shiftmeup
End Sub
Sub shiftmeup()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts
With ws.Range("D11:BJ392")
For i = .Rows.Count To 1 Step -1
If IsEmpty(.Cells(i, 1)) Then .Rows(i).Delete Shift:=xlUp
Next
End With
End Sub
Why not change this line:
ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents
To this:
ws.Range("C" & ActiveCell.Row & "BJ" & ActiveCell.Row).EntireRow.Delete
This way you can avoid your second sub all together (or keep this as an occasional cleaner rather run it every time you simply need to delete 1 row.)
If you really do need both subs, a common first step for efficiency is to disable screen updating before entering your loop with Application.ScreenUpdating = False and then re-activate it when your loop ends by changing False to True.
This is the followup to urdearboy's answer...
The issue was in your second function and the static range used. You were deleting all the rows at the end, past your data (up to ~380 extra delete row calls). To fix it you should do two things
Only loop to the last row of data
Limit calls to the front end; put all the cells you want to delete into one range and delete it once
Sub ShiftMeUp()
Dim wb As Workbook
Dim ws As Worksheet
Dim DeleteRowRange As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts
For i = 1 To GetLastRow(1, ws)
If IsEmpty(ws.Cells(i, 1)) Then Set DeleteRowRange = MakeUnion(ws.Rows(i), DeleteRowRange)
Next
If Not DeleteRowRange Is Nothing Then DeleteRowRange.EntireRow.Delete Shift:=xlUp
End Sub
I used 2 on my commonly used functions to keep the code clean...
MakeUnion
Public Function MakeUnion(Arg1 As Range, Arg2 As Range) As Range
If Arg1 Is Nothing Then
Set MakeUnion = Arg2
ElseIf Arg2 Is Nothing Then
Set MakeUnion = Arg1
Else
Set MakeUnion = Union(Arg1, Arg2)
End If
End Function
GetLastRow
Public Function GetLastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
GetLastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
I'm not a programmer for the profession, I'm a system administrator who usually brings together the puzzle when I try something. Now I would need help simplifying an Excel form to make it useful. It will be used by me.
I have a combobox that contains 4 columns. I also have a button. When you click the button, I want to save data from the four columns in my combobox to the next available row of cells starting from row 3. I want data to be saved only to row 30. I have tested back and forth but do not get it, so I've completely deleted the code. Any ideas?
Sheet named "Data"
I use ListFillRange in my ComBobox for the data source.
Private Sub CommandButton1_Click()
Call SaveComboBoxData
End Sub
Sub SaveComboBoxData()
End sub
Using ActiveX controls
ComboBox1
CommandButton1
You can tidy this up further,
Note:
You appear to be building a database so consider the preferred option of using an access database to store this data
If you have Excel 2016 you could be using Data Entry Forms instead which are dead simple.
Assume using ActiveX combobox. You will need to alter this
Set sourceCombo = sourceSheet.OLEObjects("Combobox1").Object
if working with a form control.
Code for the type of operation you are describing:
Code pane for Order sheet:
Option Explicit
Private Sub CommandButton1_Click()
AddRecords
End Sub
Standard module
Option Explicit
Public Sub AddRecords()
Dim wb As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set sourceSheet = wb.Worksheets("Order")
Set targetSheet = wb.Worksheets("Data")
Dim lastRowTarget As Long
Dim sourceCombo As ComboBox
Set sourceCombo = sourceSheet.OLEObjects("Combobox1").Object 'assume activex object
Dim lRow As Long
Dim lCol As Long
Dim nextRow As Long
With sourceCombo
For lRow = 0 To .ListCount - 1
If lRow = sourceCombo.ListIndex Then
nextRow = GetNextRow(targetSheet)
If nextRow = 31 Then
MsgBox "End row of 30 reached"
Exit Sub
End If
For lCol = 0 To .ColumnCount - 1
targetSheet.Cells(nextRow, lCol + 1) = .List(lRow, lCol)
Next lCol
Exit For
End If
Next lRow
End With
End Sub
Private Function GetNextRow(targetSheet As Worksheet) As Long
With targetSheet
GetNextRow = IIf(.Cells(.Rows.Count, "A").End(xlUp).Row < 3, 3, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
End With
End Function
Code in action:
References:
How to get selected value in multicolumn listbox
How can I find the index of the selected choice in a combobox?
How to create a data entry form