How to hide and copy a checkbox using vba - vba

I have the base column with the checkbox, (the D column in my code), and i want to copy that column with the checbox to the other columns, but the column D must be hide(all the data including the checkbox).
the problem here is:
i don't know how to hide the checbox, when i hide the column the checbox still visible.
when i coppy the column the checbox in the colum does not be copied
This is the fuction that i actually used.
Private Sub cmdAddNewXref_Click()
Columns("D:D").Select
Selection.Copy
i = 3
Cells(2, i).Select
Do
i = i + 1
Loop While Cells(2, i) <> ""
Cells(2, i).Select
'MsgBox ActiveCell.Column
Columns(i - 1).Select
Columns("D:D").Select
Selection.Copy
Columns(i).Select
ActiveSheet.Paste
Selection.EntireColumn.Hidden = False
Application.CutCopyMode = False
Range("A1").Select
End Sub
but most importantly what i want to do, is possible?
EDIT 1: actually thanks to Scott Holtzman i can hide the checkbox with the columns.

Give this is a shot. There's probably a bit more of ideal way to do it, but I tested it and got it to work.
There are some assumptions on cell ranges and such that you will need to adjust to meet your exact spreadsheet specs.
Option Explicit
Private Sub cmdAddNewXref_Click()
Dim i As Integer
Dim ws As Worksheet
Set ws = Worksheets("mySheet") 'change as needed
'find next column to copy
i = 3
Do
i = i + 1
Loop While ws.Cells(2, i) <> ""
With ws.Columns("D:D")
.EntireColumn.Hidden = False
.Copy Columns(i)
End With
'copy checkbox in column D
Dim cb As Shape
Set cb = ws.Shapes("CheckBox1") 'change name as needed
cb.Copy
ws.Cells(4, i).Select 'assumes checkbox should be in row 4, change to wherever it is on column D for you
ws.Paste
ws.Columns("D:D").EntireColumn.Hidden = True
End Sub

CHange the paste, to paste special values, to hide the check its the .visible property I believe.
hope this helps.
From what I gathered... Copying the row, to somewhere else, but not the control, then he wanted to hide copied row. :)
Option Explicit
Sub test()
' From above code in yours I will be col number
Dim i As Integer
i = 5
Columns("A:A").Copy
Sheet2.Activate
ActiveSheet.Cells(1, i).PasteSpecial xlPasteValues
End Sub

Related

First VBA code... looking for feedback to make it faster

I wrote a small VBA macro to compare two worksheets and put unique values onto a new 3rd worksheet.
The code works, but every time I use if excel goes "not responding" and after 30-45sec comes back and everything worked as it should.
Can I make this faster and get rid of the "not responding" issue? is it just my computer not being fast enough?
I start with about 2500-2700 rows in each sheet I'm comparing.
Sub FilterNew()
Dim LastRow, x As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Sheets(1).Select
LastRow = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
For Each Cell In Range("B2:B" & LastRow)
x = 2 'This is for looking through rows of sheet2
Dim unique As Boolean: unique = True
Do
If Cell.Value = Sheets(2).Cells(x, "B").Value Then 'Test if cell matches any cell on Sheet2
unique = False 'If the cells match, then its not unique
Exit Do 'And no need to continue testing
End If
x = x + 1
Loop Until IsEmpty(Sheets(2).Cells(x, "B"))
If unique = True Then
Cell.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub
This belongs in Code Review, but here is a link
http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html
With your code your main issues are:
Selecting/Activating Sheets
Copy & pasting.
Fix those things and youll be set straight my friend :)
instead of a do...loop to find out duplicate, I would use range.find method:
set r = SHeets(2).range("b:b").find cell.value
if r is nothing then unique = true else unique = false
(quickly written and untested)
What about this (it's should help):
Sub FilterNew()
Dim Cel, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Set Rng = Sheet(1).Range("B2:B" & Sheet(1).Range("B1").End(xlDown).Row)
For Each Cel In Rng
If Cel.Value <> Sheet(2).Cells(Cel.Row, 2).Value Then Cel.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) ' The only issue I have with this is that this doesn't actually tell you if the value is unique, it just tells you ins not on the same rows of the first and second sheet - Is this alright with you?
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Excel macro - check for a string in a cell, run a routine, move to the next row, do it again

I am not a Dev, but given I do use Excel, I have been tasked to create a looping macro that will check for a string ('Resource') in a cell and if it finds that string, then run a Copy and Paste code and then move to the next row. This starts at row 5 and runs continuously until row 199, but does not work on every row, hence the validation for the string Resource.
I have managed to create the macro for the Copy and Paste but it also has issues as I created it using the macro recorder and it only works on the row I actually did the recording on.
I am at a complete loss, can anyone help?
this is what I have so far
A New Resource name is added manually to the spreadsheet
the user clicks cell (C6) to focus the curser
the user clicks a macro button called 'Forecast for Future Project 1' to start the macro
On the button click the Macro will:
Interogate if cell to the left of current cell (B6) = 'Resource'
IF Yes, THEN
Sub CP()
DO
Range("C6").Select
Selection.Copy
Application.Goto Reference:="ProjAdd"
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=SUMIF('Current Project Utilisation'!R2C1:R62C1,RC1,'Current Project Utilisation'!R2C:R62C)+SUMIF('Future Project 1'!R2C1:R62C1,RC1,'Future Project 1'!R2C:R62C)"
Range("ProjAdd").Select
Selection.Copy
Range("C6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Paste
Range("B6").Select
Loop Until ActiveCell.Address(0,0) = "$B$199"
End Sub
Move to cell under original active cell (C7) and Repeat the Macro until cell C199 is reached
If (B6) does not = 'Resource' then move to go to the cell under (C7) aand Repeat the Macro until cell C199 is reached
Refresh Worksheet to update data
Would something like this work for you?
Sub CopyPasteResource()
Dim CopyRange As Range
Dim Cell As Range
Set CopyRange = Workbooks("YourWorkBookName").Sheets("Sheet1").Range("C6:C199")
For Each Cell In CopyRange
If InStr(1, Cell.Offset(0, -1).Text, "Resource") Then
Cell.Copy
'paste where you wish
End If
Next Cell
End Sub
EDIT: Or do you want to loop through B6:B199 and then C6:199? I'm not entirely clear on the aim.
Ah the old macro recorder, generating 90% extra code since 1997. I couldn't exactly figure out from your question what exactly is being copied and to where but this code will loop through rows 5 to 199, check if the value in column B = "Resource" and then set the corresponding value in column C, you should be able to modify for your needs but I think you definitely want a structure more like this than what the recorder generated for you..
public sub cp()
Dim ws as Worksheet
Set ws = Worksheets("Current Project Utilisation")
Dim i as int
for iI = 5 to 199
if(ws.cells(i, 2).value = "Resource") then
ws.cells(i, 3).value = "what you're copying"
end if
next I
end sub
Assuming your cell range doesn't change you can do this for the looping part
Sub ResourceCheck()
Dim WS As Worksheet
Set WS = ActiveSheet
Dim Resources() As Long, r As Long
ReDim Resources(5 To 199)
For r = 5 To 199
If UCase(WS.Cells(r, 2).Value) = "RESOURCE" Then
WS.Cells(r, 3).Value = "x"
'Do copy paste part
End If
Next r
Application.Calculate
End Sub
Can you add a sample of your data? It's a bit hard to see what you're referencing to and how the data relates to each other.
Also, where is the "Projadd" cell reference? And what does it do?
Sub CP()
' I like to know what worksheet I'm on
Dim ws as Worksheet
' if it's a dedicated worksheet use this
' Set ws = ThisWorkbook.Worksheets("Sheet1")
' Otherwise following your current code
Set ws = ActiveSheet
' I also like to grab all my data at once
Dim Data as Variant
Data = ws.Range("B6:B199")
' No need to focus the cursor
For row = 5 to 199
' No need to select any range
' Is this case-sensitive???
If Data(row-4, 1) = "Resource" Then
' Copy C6??? Paste 'ProjAdd'
ws.Cells(row, 3).Copy Range("ProjAdd")
Application.CutCopyMode = False
End If
Next
End Sub

For loop to change a specific cell in a formula

I have a formula that shows which rows in a specific column meet a set of criteria. When the formula is executed and applied to all rows, I run a loop to check which rows returned a value as a text, and then copy-pastes this cells to another worksheet:
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Range(.Cells(c.Row, "AF"), .Cells(c.Row, "AF")).Copy
Else
GoTo nextc
End If
With Worksheets("Sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
nextc:
Next c
End With
Application.CutCopyMode = False
End Sub
What I want to do now is to run the formula for 631 different names, copy-paste every name as a headline and then run loop1. I cant figure out though how to make the for loop work inside the formula.
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Select
Range("AC2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R2C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Range("AC2").Select
Selection.AutoFill Destination:=Range("AC2:AC20753")
Range("AC2:AC20753").Select
Range("AG2").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Sheet1").Select
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
The cells that need to be changed for every loop are, R2C33 to something like RiC33 (which doesn't work) and the "headline" Range("AG2").Select to something like Range("AGi").Select.
Anyone who could help?
The following code will do the trick:
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Range("AC2:AC20753").FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R" & i & "C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Sheets("Sheet1").Range("AG" & i).Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Range("A1").Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
In order to let i be used within your String formula you have to stop the String " use & i & and continue the String ".
I have also changed your code to prevent the use of .Select, which is a no no in VBA.
This way it fills in your Formula copy's and changes the Font without selecting anything or changing sheets.
As Jeep noted you do however need to change Sheets(""Sheet2").Range("A1") as I don't know which cell you want to paste into.
Your first sub procedure might be better like this.
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = _
.Cells(c.Row, "AF").Value2
End If
Next c
End With
End Sub
Direct value transfer is preferred over a Copy, Paste Special, Values.
In the second sub procedure, you don't have to do anything but remove the 2 from R2C33; e.g. RC33. In xlR1C1 formula construction a lone R simply means the row that the formula is on and you are starting at row 2. You can also put all of the formulas in at once. Once they are in you can looop through the G2:G632 cells.
Sub loop2()
Dim i As Integer
With Sheets("Sheet1")
.Range("AC2:AC20753").FormulaR1C1 = _
"=IF(OR(AND(RC[-3]=""district1"", RC[2]=R2C33, RC[-18]>=1), SUM(RC[-16], RC[-14], RC[-12])>=1), 0, IF(SUM(RC[-10], RC[-8], RC[-6])>=1, 1, 0))"
For i = 2 To 632
.Range("AG" & i).Copy _
Destination:=Sheets("Sheet2").Somewhere
Sheets("Sheet2").Somewhere.Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
Next i
End Sub
I also tightened up your formula by grouping some of the conditions that would result in zero together with OR and AND functions.
The only thing remaining would be defining the Destination:=Sheets("Sheet2").Somewhere I left hanging.

How To Paste My Formula In A Cell With Specific Text Instead Of A Column?

I pretty much have an already working macro for me but for the future it may cause problems because the macro i have finds the column i gave it and then starts to input the formula there. Now my data may change in the future and in that column i might have something new so the macro would obviously run the formulas to the wrong column. Changing it manually is possible but hectic and a lot of work. Is there any possible way i can select a cell with a specific text in it instead of the column? since the text will never change this will me much easier for me to work with. Because doing this the formulas will always be posted in the correct column.
EDIT! I added the whole code to the post so you can see it more clearly and understand what i mean more clearly.
Sub HW_Copy_RawData_Formulas()
Dim intChoice As Integer
Dim strPath As String
Dim I As Integer
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Dim Lastrow As Long
Dim Nrow As Long
Set TargetWb = ActiveWorkbook
' Delete Rows
On Error Resume Next
TargetWb.Worksheets("Raw Data").Activate
Range("A2:AL2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A2:AL2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
'Copy Formulas
Range("AF2").Formula = "=IF([#ServDt]<DATE(2013,1,1), DATE(YEAR([#ServDt]),12,31),EOMONTH([#ServDt],0))"
Range("AG2").Formula = "=IF([#Amount]>1,[#Quantity],0)"
Range("AH2").Formula = "=IF([#Amount]<>0,[#Amount]-[#Adj]-[#[Adjustment ]],0)"
Range("AI2").Formula = "=IF(AND([#Department]=""HH"",[#Pay]=0),[#Amount]/2,0)"
Range("AJ2").Formula = "=IF([#Amount]<>0,[#Bal]-[#[Adjustment ]],[#Bal]+[#Adj])"
Range("AK2").Formula = "=VLOOKUP([Department],Service[#All],2,FALSE)"
Range("AL2").Formula = "=VLOOKUP([#Entity],Site,3,FALSE)"
MSG1 = MsgBox("Add Raw Data", vbYesNo)
If MSG1 = vbYes Then
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else: GoTo endmsg
End If
'Setting source of data
Set SourceWb = Workbooks.Open(strPath)
Lastrow = SourceWb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
SourceWb.Worksheets(1).Range("A2:BJ" & Lastrow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy Destination:=TargetWb.Sheets("Raw Data").Range("A2")
' Close the source workbook without saving changes.
SourceWb.Close savechanges:=False
Else
endmsg:
MsgBox "Complete"
End If
Range("AF2:AL2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("AF2").PasteSpecial xlPasteValues
End Sub
The following code snippet might be of use to you. It acquires the range of the cell given a specific value. It can also be used to search a specific row with .Rows() instead.
Dim *YOURCELL* As Range
Set *YOURCELL*= .Columns(1).Find(What:= *WHATYOUWANTTOFIND*, LookAt:=xlWhole, MatchCase:=False, searchformat:=False)
If, however, you do not know where the last used cell is located, then consider reading this other post.
EDIT:
The while loop runs as long as the currently selected cell is not empty. In this loop, it selects the next cell to the right and increments a count. After the loop has finished, the currently selected cell is the first empty cell in the second row. Count has found the column number of it by incrementing alongside the loop, so it can then be used as needed. I used cells instead of range afterwards because it can use the column number.
Range("A2").Select
Dim count As Integer
count = 1
'skip all used cells in the row
Do While Not (ActiveCell.value = None)
ActiveCell.Offset(0, 1).Range("A1").Select
count = count + 1
Loop
Cells(count, 2).Formula = your_formula
Cells(count + 1, 2).Formula = your_formula ' next cell to the right
Cells(count + 2, 2).Formula = your_formula ' next cell to the right

how to copy one column from one spreadsheet to another

I am trying to copy the data from column A in spreadsheet called "Dividends" and paste in spreadsheet called "Draft" but there`s an error. My code looks like that:
Sub copy_2()
Sheets("Dividends").Range("A").Copy
Sheets("Draft").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
You don't need to copy/paste either - you can just set the ranges equal.
Sub copy()
Dim lastRow As Integer
'This will let us know the last used row in column A
lastRow = Sheets("Dividends").Cells(1, 1).End(xlDown).row
Sheets("Draft").Range(Sheets("Draft").Cells(1, 1), Sheets("Draft").Cells(lastRow, 1)).Value = Sheets("Dividends").Range(Sheets("Dividends").Cells(1, 1), Sheets("Dividends").Cells(lastRow, 1)).Value
End Sub
Or you can copy/paste:
Sub copy()
Dim lastRow As Integer
'This will let us know the last used row in column A
lastRow = Sheets("Dividends").Cells(1, 1).End(xlDown).row
Sheets("Dividends").Range(Sheets("Dividends").Cells(1, 1), Sheets("Dividends").Cells(lastRow, 1)).copy _
Destination:=Sheets("Draft").Range(Sheets("Draft").Cells(1, 1), Sheets("Draft").Cells(lastRow, 1))
Application.CutCopyMode = False
End Sub
Note: If you have a gap anywhere in Column A, the lastRow integer might be off. If you want to copy all the way down to the last used row, replace the "lastRow = " with this:
lastRow = Sheets("Dividends").UsedRange.Rows.Count
Sub copy_2()
Sheets("Dividends").Range("A:A").Copy
Sheets("Draft").Paste
Application.CutCopyMode = False
End Sub
Removing references to Active as much as possible helps eliminate confusion.
This works,
Sheets("Dividends").Range("A:A").Copy Sheets("Draft").Range("A1")