I am trying to use multiple form option buttons as shown in the code below. The objective is to copy a range of data from one column and paste them and values in another column. Nothing fancy. So, I have multiple option buttons and one command button which is Button38. When I run the code, I don't get error messages and it's not working. Any help will be very appreciated, also I am new to VBA.
Sub Button38_Click()
Application.ScreenUpdating = False
Sheets("Sheet2").Visible = True
Sheets("Sheet2").Select
If OptionButton22 = True Then
Range("AI2:AI182").Copy
Range("AK2:AK182").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
ElseIf OptionButton23 = True Then
Range("AD2:AD182").Copy
Range("AK2:AK182").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
ElseIf OptionButton24 = True Then
Range("AE2:AE182").Copy
Range("AK2:AK182").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
End If
Sheets("Sheet1").Select
Sheets("Sheet2").Visible = False
Application.ScreenUpdating = True
End Sub
I re-set everything to Sheet1, and sheet2. Sheet1 being the one that has the Form option buttons, and sheet2 has the columns. I want sheet2 to be hidden all time.
You are using Form Control (Option Button). Also you do not need to unhide/hide the sheets. Let it remain hidden. This code will work and the range will get copy pasted even when Sheet2 is hidden.
Is this what you are trying?
Sub Button38_Click()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim sCol As String
Set wsThis = Sheet2 '<~~ This sheet has the range
Set wsThat = Sheet1 '<~~ This sheet has FORM option buttons
With wsThis
If wsThat.Shapes("Option Button 22").OLEFormat.Object.Value = 1 Then sCol = "AI"
If wsThat.Shapes("Option Button 23").OLEFormat.Object.Value = 1 Then sCol = "AD"
If wsThat.Shapes("Option Button 24").OLEFormat.Object.Value = 1 Then sCol = "AE"
.Range(sCol & "2:" & sCol & "182").Copy
.Range("AK2:AK182").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
If you qualify all your objects to their parent the code should work. See below. (I also refactored the code a bit to make it cleaner, easier to maintain / read, and shorter).
Sub Button38_Click()
Dim ws1 as Worksheet
Set ws1 = Worksheets("Sheet1")
Application.ScreenUpdating = False
With Sheet2 'using the VBA sheet object name (change if needed)
.Visible = xlSheetVisible
Dim sCol As String
If .OptionButton22 = True Then
sCol = "AI"
ElseIf .OptionButton23 = True Then
sCol = "AD"
ElseIf .OptionButton24 = True Then
sCol = "AE"
End If
.Visible = xlSheetHidden
End With
ws1.Range("AK2:AK182").Value = ws1.Range(sCol & "2:" & sCol & "182").Value
'if you need the range theme copied as well use the code below
'With ws1
'.Range(sCol & "2:" & sCol & "182").Copy
'.Range("AK2:AK182").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
'End With
End Sub
Related
I'm running a Macro that creates a new workbook and a tab in that workbook based on a dropdown selection. I'm running into issues with my conditional formatting. When I run the macro the conditional formatting rules are there but the color output changes. For example I have a conditional formatting that changes a number green based on another value but after running the macro the color changes to Orange. Doe's anyone know why?
Here's the code that I'm running
Sub BusinessPlan_Create()
Dim cell As Range
Dim counter As Long
Dim Dashboard As Worksheet
Dim newWB As Workbook
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
Set newWB = Workbooks.Add
Set Dashboard = wb1.Sheets("Facility View")
Application.DisplayAlerts = False
For Each cell In wb1.Worksheets("dd").Range("$B3:$B87")
If cell.Value = "" Then
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
Else
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
With Dashboard
.Range("$B$1").Value = cell.Value
With wb1
.Worksheets("Facility View").Copy After:=newWB.Worksheets(1)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteSpecialOperationAdd
ActiveSheet.Name = cell.Value
End With
Application.CutCopyMode = False
End With
End If
Next cell
newWB.Activate
Call SortWorkBook2
Application.DisplayAlerts = True
Range("C6:D6").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Range("C4").Select
Application.CutCopyMode = False
End Sub
I have a spreadsheet for entering a new set of data on a new row each day each day, the row contains formulas and formatting. I want to be able to click a button and it adds a row under the last row with entered data and copy the formulas and formatting only, ready for new data to be entered.
Below is my code:
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
Set ws = ThisWorkbook.Sheets("Summary")
With ws
varUserInput = .Range("D" & .Rows.Count).End(xlUp).Row
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub
The issue is that it will only copy the formula from the same hidden row each time.
Is this what you are trying (UNTESTED)?
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
varUserInput = InputBox("Enter Row Number where you want to add a row:", "What Row?")
If varUserInput = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets("Sheet1") '<~~ Change as applicable
With ws
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub
I want to write code that allows the user to select a number of sheets in the open workbook and copy them as values into another workbook, which is saved in the same location as the original (with a different name not specified by the user). (I am a relatively new user to VBA, but have had some previous experience with programming before).
I have managed to write code that generates a dialog box populated with check boxes based on the sheets in the work book and create a new file and save it in the appropriate location.
However, I have come across issues at looping through the selected sheets, and copying and pasting them into the new book as values. When I open up the newly created workbook, it is empty. So it seems that the copy/paste has not worked.
The code was originally based off code I found on the net to select any sheets and print them. Any insight to the below code would be greatly appreciated. (I included the extra code that works just in case there is some underlying issue in there that is preventing later code from working).
Sub CreateCirculationCopy()
Dim CurrentSheet As Worksheet
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim SelectDlg As DialogSheet
Dim cb As CheckBox
Dim Current As String
Dim x As Integer
Application.ScreenUpdating = False
'Add a temp dialog sheet
Set CurrentSheet = ActiveSheet
Set SelectDlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'Skip empty and hidden sheets
If CurrentSheet.Visible Then
SheetCount = SheetCount + 1
SelectDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
SelectDlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next i
'Format dialog box
SelectDlg.Buttons.Left = 240
With SelectDlg.DialogFrame
.Height = Application.Max _
(68, SelectDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to copy"
End With
SelectDlg.Buttons("Button 2").BringToFront
SelectDlg.Buttons("Button 3").BringToFront
'Display the dlg box
Set wb = Workbooks.Add
x = 1
Application.DisplayAlerts = False
CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If SelectDlg.Show Then
For Each cb In SelectDlg.CheckBoxes
If cb.Value = x10n Then
Worksheets(cb.Caption).Activate
ActiveSheet.Cells.Copy
'ActiveSheet.UsedRange.Copy
Windows(wb).Activate
wb.Sheets("Sheet" & x).Activate
ActiveSheet.Cells("A1").PasteSpecial xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(1).Activate
Worksheets(cb.Caption).Activate
x = x + 1
End If
Next cb
End If
Else
MsgBox "All worksheets are empty"
End If
Filename = ThisWorkbook.Path & "\" & "Circulation.xlsx"
wb.SaveAs Filename, XlFileFormat.xlOpenXMLWorkbook
wb.Close
SelectDlg.Delete
Application.DisplayAlerts = True
CurrentSheet.Activate
End Sub
Use DialogSheet is interesting, but simpler way is create userform with listbox and allow user multiselect ListBox1.MultiSelect = fmMultiSelectMulti.
But that is not important :)
Using your, I had a problem with If cb.Value = x10n Then, x10n is equal to Empty.
Second problem Windows(wb).Activate, wb it is an object, i use Windows(wb.Name).Activate
I had a problem with copying: ActiveSheet.Cells("A1").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
i change it to Selection.PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Part of the code with minor modifications:
If SelectDlg.Show Then
For Each cb In SelectDlg.CheckBoxes
If cb.Value = 1 Then
Worksheets(cb.Caption).Activate
ActiveSheet.Cells.Copy
Windows(wb.Name).Activate
wb.Sheets("S" & x).Activate
Selection.PasteSpecial xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(1).Activate
Worksheets(cb.Caption).Activate
x = x + 1
End If
Next cb
End If
Let me know if it worked
I have the following VBA code that takes a single row from Sheet "Tabled data", copies the data, then pastes the data into the next available row in Sheet "Running list". However the original row has formulas and I need the values to paste, not the formulas. I've seen numerous ways to do it with Range.PasteSpecial but this code didn't use Range and I'm not sure how to incorporate it.
Note: I modified this code from here: http://msdn.microsoft.com/en-us/library/office/ff837760(v=office.15).aspx. It originally had an IF statement to match content in a cell then paste it in a certain sheet according to the content in the cell. I only had one sheet to copy to and didn't need the IF. I don't really need to find the last row of data to copy either as it will only ever be one row with range of A2:N2. But if I take out the FinalRow section and the For and replace with Range("A2:N2") it doesn't work so I left those in.
Any guidance on how to add in the PasteValues property without making this more complicated? I'm also open to simplification of the For or FinalRow variable such as using Range. I'm only sort of familiar with VBA, having done a few things with it, but usually after much searching and modifying code.
Public Sub CopyData()
Sheets("Tabled data").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
ThisValue = Cells(x, 1).Value
Cells(x, 1).Resize(1, 14).Copy
Sheets("Running list").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Tabled data").Select
Next x
End Sub
Hopefully we can actually make this more simple.
Public Sub CopyRows()
Sheets("Sheet1").UsedRange.Copy
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'check if the last cell found is empty
If IsEmpty(ActiveSheet.Cells(lastrow, 1)) = True Then
'if it is empty, then we should fill it
nextrow = lastrow
Else
'if it is not empty, then we should not overwrite it
nextrow = lastrow + 1
End If
ActiveSheet.Cells(nextrow, 1).Select
ActiveSheet.Paste
End Sub
edit: I expanded it a little so that there won't be a blank line at the top
I found a working solution. I recorded a macro to get the paste special in there and added the extra code to find the next empty row:
Sub Save_Results()
' Save_Results Macro
Sheets("Summary").Select 'renamed sheets for clarification, this was 'Tabled data'
'copy the row
Range("Table1[Dataset Name]").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
' paste values into the next empty row
Sheets("Assessment Results").Select
Range("A2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Return to main sheet
Sheets("Data Assessment Tool").Select
End Sub
Just copy the data all at once, no need to do it a row at a time.
Sub CopyData()
With ThisWorkbook.Sheets("Tabled data")
Dim sourceRange As Range
Set sourceRange = .Range(.Cells(2, 1), .Cells(getLastRow(.Range("A1").Parent), 14))
End With
With ThisWorkbook.Sheets("Running list")
Dim pasteRow As Long
Dim pasteRange As Range
pasteRow = getLastRow(.Range("A1").Parent) + 1
Set pasteRange = .Range(.Cells(pasteRow, 1), .Cells(pasteRow + sourceRange.Rows.Count, 14))
End With
pasteRange.Value = sourceRange.Value
End Sub
Function getLastRow(ws As Worksheet, Optional colNum As Long = 1) As Long
getLastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
End Function
Private Sub Load_Click()
Call ImportInfo
End Sub
Sub ImportInfo()
Dim FileName As String
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim ActiveListWB As Workbook
Dim check As Integer
'Application.ScreenUpdating = False
Set WS2 = ActiveWorkbook.Sheets("KE_RAW")
confirm = MsgBox("Select (.xlsx) Excel file for Data transfer." & vbNewLine & "Please ensure the sheets are named Sort List, Second and Third.", vbOKCancel)
If confirm = 1 Then
FileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select Active List to Import", MultiSelect:=False)
If FileName = "False" Then
MsgBox "Import procedure was canceled"
Exit Sub
Else
Call CleanRaw
Set ActiveListWB = Workbooks.Open(FileName)
End If
Set WS1 = ActiveListWB.Sheets("Sort List")
WS1.UsedRange.Copy 'WS2.Range("A1")
' WS2.Range("A1").Select
WS2.UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'WS2.Range ("A1")
ActiveWorkbook.Close False
'Call ClearFormulas
' Call RefreshAllPivotTables
Sheets("Key Entry Data").Select
'Sheets("Raw").Visible = False
'Application.ScreenUpdating = True
MsgBox "Data has been imported to workbook"
Else
MsgBox "Import procedure was canceled"
End If
Application.ScreenUpdating = True
End Sub
Sub CleanRaw()
Sheets("KE_RAW").Visible = True
Sheets("KE_RAW").Activate
ActiveSheet.Cells.Select
Selection.ClearContents
End Sub
I have a sheet(Questions) in a workbook(Rating) that has a button at the bottom of the Questions sheet that copies sheet 2(quote) from the Rating workbook and pastes it in a new workbook that is named according to the quote number and then saved.
Here is that code:
Sub GetQuote()
Range("AK548").Select
Selection.Copy
Range("AK549").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim Output As Workbook
Dim FileName As String
Set Output = Workbooks.Add
FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("AK545").Value & ".xls"
Output.SaveAs FileName
Application.DisplayAlerts = False
Output.Worksheets("Sheet1").Delete
ThisWorkbook.Worksheets(2).Copy Before:=Output.Worksheets("Sheet2")
Output.Worksheets(1).Name = "Sheet1"
Application.DisplayAlerts = True
Output.Protect Password:="12345"
Output.Save
End Sub
Now I intend on removing the links that now exsist between this new copy and the Quote sheet and only leave the values. How would I do this?
I have found this code that should delete the links that exsist:
Dim Cell As Range, FirstAddress As String, Temp As String
'delete all links from selected cells
Application.ScreenUpdating = False
With Selection
Set Cell = .Find("=*!", LookIn:=xlFormulas, searchorder:=xlByRows, _
LookAt:=xlPart, MatchCase:=True)
On Error GoTo Finish
FirstAddress = Cell.Address
Do
Temp = Cell
Cell.ClearContents
Cell = Temp
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End With
Finish:
All I have done extra is put this code in below the code that Names and copies the sheet and that did not work?
So now how would I combine these two pieces of code so that everything gets copied and the links removed?
I had existing workbooks that had external links that i needed to remove from the workbooks and then re save them.
This worked for me:
Sub BreakExternalLinks()
'PURPOSE: Breaks all external links that would show up in Excel's "Edit Links" Dialog Box
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
Dim ExternalLinksArray As Variant
Dim wb As Workbook
Dim x As Long
Set wb = ActiveWorkbook
'Create an Array of all External Links stored in Workbook
ExternalLinksArray = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
'if the array is not empty the loop Through each External Link in ActiveWorkbook and Break it
If IsEmpty(ExternalLinksArray) = False then
For x = 1 To UBound(ExternalLinksArray )
wb.BreakLink Name:=ExternalLinksArray (x), Type:=xlLinkTypeExcelLinks
Next x
end if
End Sub
This piece of code kills all connections in the active workbook... apologies, but can't remember where I got it.
'Kill Connections
If ActiveWorkbook.Connections.Count > 0 Then
For i = 1 To ActiveWorkbook.Connections.Count
ActiveWorkbook.Connections.Item(1).Delete
Next i
Else
End If
Tested with your code, this seems to work:
Dim Output As Workbook
Dim FileName As String
Set Output = Workbooks.Add
FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("A1").Value & ".xls"
Output.SaveAs FileName
Application.DisplayAlerts = False
Output.Worksheets("Sheet1").Delete
ThisWorkbook.Worksheets(2).Copy Before:=Output.Worksheets("Sheet2")
Output.Worksheets(1).Name = "Sheet1"
Output.Worksheets(1).Select
If ActiveWorkbook.Connections.Count > 0 Then
For i = 1 To ActiveWorkbook.Connections.Count
ActiveWorkbook.Connections.Item(1).Delete
Next i
Else
End If
Application.DisplayAlerts = True
Output.Protect Password:="12345"
Output.Save
Perhaps it would help, if you don't use the actual copy & paste functions. If you only need the values of the cells, then change your macro to
Sub GetQuote()
Range("AK548").Select
Selection.Copy
Range("AK549").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim Output As Workbook
Dim FileName As String
Set Output = Workbooks.Add
FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("AK545").Value & ".xls"
Output.SaveAs FileName
Application.DisplayAlerts = False
Dim v, r As Long, c As Long
With ThisWorkbook.Worksheets(2)
r = .Cells.SpecialCells(xlCellTypeLastCell).Row
c = .Cells.SpecialCells(xlCellTypeLastCell).Column
v = .Range(.Cells(1, 1), .Cells(r, c))
End With
With Output.Worksheets(1)
.Range(.Cells(1, 1), .Cells(r, c)) = v
End With
Application.DisplayAlerts = True
Output.Protect Password:="12345"
Output.Save
End Sub
This copies the values of your origin sheet to the new workbook sheet, without any links.
P.S.: Don't mix up ThisWorkbook and ActiveWorkbook. ThisWorkbook is the workbook where the macro is located (, but not necessarily the active workbook). ActiveWorkbook is the workbook, you see at that time.