Sheet 1 in workbook A contains some cells with formulas that are protected and some cells that are used to enter data that are unprotected. There are multiple files that uses this structure.
I have now updated the formulas in a template file that use the same structure.
What I want to do is to copy all unprotected cells and move them to the same place in the new file.
Let’s say the range is A1:R99 and I have unprotected cells in B1:B99 and G1:G99 (multiple different places in real file so entering all different ranges would take a long time) Then I want to copy B1:B99 to the same place in the new file.
Hope there is a better way to do this than to enter every range manually!
Suppose you have the data in 'Sheet1' and if you want to copy all the unprotected cells to a new sheet, lets say 'Sheet2' in the same location as they were in 'Sheet1', then
Sub Foo()
If Sheets("Sheet1").ProtectContents = True Then
Worksheets("Sheet1").Activate
For i = 1 To 99
For j = 1 To 18
If Cells(i, j).Locked = False Then
a = Cells(i, j).Value
Worksheets("Sheet2").Activate
Cells(i, j).Value = a
Worksheets("Sheet1").Activate
End If
Next j
Next i
End If
End Sub
Related
Background: This is my first time dealing with macros. I will have two worksheets that I’ll be using. The first sheet, ‘Source’ will have data available. The second sheet, ‘Final’ will be blank and is going to be where the macro will be pasting the data I’d like it to collect from the ‘Source’ sheet.
* I want the macro to find the specified header in the ‘Source’ sheet, copy that cell containing the header all the way down to the last row of existing data (instead of the entire column), and paste it onto the ‘Final’ sheet in a specified column (A, B, C, etc.). *
The reason why I have to specify which headers to find is because the headers in the ‘Source’ sheet won’t always be in the same position, but the ‘Final’ sheet’s headers will always be in the same position – so I CAN’T just record macros copying column A in ‘Source’ sheet and pasting in column A in ‘Final’ sheet. Also, one day the ‘Source’ sheet may have 170 rows of data, and another day it may have 180 rows.
Although, it would probably be best to copy the entire column since one of the columns will have a few empty cells rather than to the last row of existing data. I’m assuming it would stop copying when it reaches the first empty cell in the column chosen which would leave out the remaining data after that empty cell in the column – correct me if I’m wrong. If copying the entire column is the best way, then, please provide that as part of the possible solution. I’ve attached an example of the before & after result I would like accomplished:
Example of Result
Find Header=X, copy entire column -> Paste into A1 in ‘Final’ sheet
Find Header=Y, copy entire column -> Paste into B1 in ‘Final’ sheet
Etc..
I’m sorry if my wording isn’t accurate – I tried to explain the best I could. It’d be awesome if someone could help me out on this! Thanks!
u can try with this. i think its clear and step-by-step. it can be very optimized, but to start with vba i think its better this way.
the name of the column must be the same in both sheets.
Sub teste()
Dim val
searchText = "TEXT TO SEARCH"
Sheets("sheet1").Select ' origin sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
x = Selection.Columns.Count ' get number of columns
For i = 1 To x 'iterate trough origin columns
val = Cells(1, i).Value
If val = searchText Then
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("sheet2").Select ' destination sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
y = Selection.Columns.Count ' get number of columns
For j = 1 To y 'iterate trough destination columns
If Cells(1, j).Value = searchText Then
Cells(1, j).Select
ActiveSheet.Paste
Exit Sub
End If
Next j
End If
Next i
End Sub
good luck
I modified an answer I gave to another user with similar problem for your case,
I use dictionary function in most of my data sheets so that I can shift columns around without breaking the code, the below code you can shift your columns around and it will still work
the only main restriction is
1. your header names must be unique
2. your header name of interest must be exactly the same.
i.e. your source header of interest is PETER then your Data table should have a header with PETER and it must be unique.
Sub RetrieveData()
Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1 'set the header row in sheet A
TableColStart_A = 1 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column 'Get number of NAMEs you have
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then 'check if the name exists in the dictionary
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
End If
Next i
End With
With ws_B 'worksheet you want to paste data into
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
For i = 1 To ws_B_lastCol 'for each data
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value)) 'get the column where the name is in Sheet A from the dictionaary
If SourceCol_A <> 0 Then 'if 0 means the name doesnt exists
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
Next i
End With
End Sub
I have filtered my cumulative sales from SalesMasterSheet to different sheets each named after each particular customer but I got stuck at trying to add excel formulas because my VBA code always clears content of the range of cells on sheetActive.
I have tried the special cell method so as to clear only constants but it doesn't work.
Any help would be appreciated.
below is my code:
Private Sub Worksheet_activate()
Dim i, LastRow
LastRow = Sheets("MasterSheet").Range("A" & Rows.Count).End(xlUp).Row
Sheets("ACCIMA").Range("A1:L500").ClearContents
For i = 2 To LastRow
If Sheets("MasterSheet").Cells(i, "C").Value = "ACCIMA" Then
Sheets("MasterSheet").Cells(i, "C").EntireRow.Copy _
Destination:=Sheets("ACCIMA").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub
So far what it does is copy entries with "ACCIMA" on column C from Mastersheet to sheet("ACCIMA"), but i would like to put a formula in sheet("ACCIMA") but because Sheets("ACCIMA").Range("A1:L500").ClearContents
all formulas clear once i make the sheet active.
Given the low amount of informations you give I sort of understood your problem this way:
If your code always clears content of the range of cells on the active sheet you should try to add the worksheet you are working on in your code, e.g.
cells(1,1).value = "test"
would turn into
worksheets("customer1").cells(1,1).value = "test"
After new informations:
Copy the content of your range "A1:K500", ignore the column "L" which has your formular and then add your formulars in column "L".
worksheets("customer1").cells(1,1).formula = "..."
Keep in mind, that your syntax for the formula changes in comparison with the synatx on the actual excel sheet.
e.g.:
=IF(A1="empty";"empty";"not empty")
Will turn into:
worksheets("customer1").cells(1,1).formula = "=IF(A1=""empty"",""empty"",""not empty"")"
I want to copy all rows that have a specific value in column E and then insert them (NOT PASTE! so i want to insert new rows start at cell A29) on another sheet.
The sheet I want to copy from is called "owssvr" and the one I want to copy to is called "AOB Approval Form". I want to insert the copied rows starting Cell A29 in the "AOB Approval Form".
When i run the code, nothing happens. No error message pops up.
Few definition of my code below:
LastRow: The last row of the "owssvr" sheet
PrimaryAOB: value that i want to lookup for in column 5. It is on the "AOB Approval Form" sheet
Here is my code:
For k = 2 To lastRow
If Worksheets("owssvr").Range("E" & k).Value = primaryAOB Then
Worksheets("owssvr").Rows(k).Copy
Worksheets("AOB Approval Form").Rows(k + 27).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
Next k
THANK YOU!
I copied your code into a new module in a blank workbook, then made the necessary mods to make it run (which it did). It looks the same as yours:
Sub Question()
Dim k As long, lastRow As Long
Dim primaryAOB As String
lastRow = Sheets(1).Range("E" & (ActiveSheet.Rows.Count)).End(xlUp).Row
primaryAOB = Sheets(2).Range("A1").Text
For k = 2 To lastRow
If Worksheets("owssvr").Range("E" & k).Value = primaryAOB Then
Worksheets("owssvr").Rows(k).Copy
Worksheets("AOB Approval Form").Rows(k + 27).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
Next k
End Sub
Since this worked, you may have just had some little syntax error somewhere while defining the variables. show us more of your procedure, that may reveal the issue! Also, have you run your code line by line? (F8)
I have been searching on the internet where to find the most efficient and simple way of the following:
I have a spreadsheet that contains 3 sheets:
information
training
Leavers
Within the information sheet, column B contains a validation text that is conditionally formatted. There are two validation options:
Active
Leaver
I want that once the cell value is changed from 'active' to 'Leaver' that the whole row would be removed from the sheet and moved to 'Leaver's sheet.
I have used the code below, it works, however if there is no Leavers it will transfer the first row of 'active'. Can anyone tell me what is the problem?
Sub AlexR688(x)
'For http://www.mrexcel.com/forum/excel-q...ific-text.html
'Using autofilter to Copy rows that contain centain text to a sheet called Errors
Dim LR As Long
Range("B2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Personal Information").Cells(Rows.Count, "B").End(xlUp).Row
LR1 = Sheets("Leavers").Cells(Rows.Count, "B").End(xlUp).Row + 1
With Sheets("Personal Informaiton").Range("B2:C" & LR)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="Leaver", _
Operator:=xlOr, Criteria2:=":Leaver"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("Leavers").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
Secondly, I want to make the same in the 'Training' sheet. But in there, column B, contains the same 'Active', 'Leavers' which is referenced from personal information. So, once the Personal information sheet column B is changed from 'active' to 'leaver', training sheet will change as well, but i want the row in the training sheet would be deleted.
Thirdly, if I accidentally moved row from Personal information sheet to Leavers sheet, is it possible that by selecting back to 'active' cell value the row would move back to where it was?
Thank you very much. Hope it is clear enough.
this is the easiest way
Private Sub imperecheaza_Click()
Dim ws As Worksheet
Dim Rand As Long
Set ws = Worksheets("BD_IR")
Rand = 3
Do While ws.Cells(Rand, 4).Value <> "" And Rand < 65000
If ws.Cells(Rand, 4).Value = gksluri.Value * 1 And ws.Cells(Rand, 5).Value = gksluri.List(gksluri.ListIndex, 1) * 1 Then
ws.Rows(Rand) = "" '(here you will delete entire Row)
gksluri.RemoveItem gksluri.ListIndex
Exit Do
End If
Rand = Rand + 1
Loop
End Sub
I have an excel file with 10 sheets. The sheets all contain the same column headers but different data. I sorted the first sheet manually and now I want all the columns in the other sheets to match the first sheet's order, I can't do them all manually because it would take me forever. How can I make all the columns across the workbook in the same order based on the first sheet order? I know little about VBA so looking for some help.
Make sure you save the entire workbook before running a macro. There is no undo.
Hope this help:
Sub ColumnRearrangement()
'Horaciux 2014-06-23
Dim nextLabel As String
Dim currentLabel As String
Dim TotalPages As Integer
Dim TotalColumns As Integer
TotalPages = 10
TotalColumns = 200
'Insert a blank column in each page
For p = 2 To TotalPages
Sheets(p).Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Select
Next
For c = TotalColumns To 1 Step -1
Sheets(1).Select
'Debug.Print "-" & Cells(1, c).Text & "-" & Str(c)
nextLabel = Cells(1, c).Text
Sheets(2).Select
For oldCulumn = 2 To TotalColumns + 1
'Debug.Print Cells(1, oldCulumn).Text & "-" & Str(oldCulumn)
currentLabel = Cells(1, oldCulumn).Text
If currentLabel = nextLabel Then
'Debug.Print currentLabel & "-" & Str(oldCulumn)
Exit For
End If
Next
For p = 2 To TotalPages
Sheets(p).Select
Columns(oldCulumn).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Next
Next
For p = 2 To TotalPages
Sheets(p).Select
Range("A1").Select
Next
End Sub
If you're looking to repeat the re-ordering of columns, you should be able to record a simple macro for this, as long as the columns in all the sheets are in the same (wrong) order. Open the second sheet (since you already arranged the first), and do the following:
Open the second sheet
Click record macro, give it any name
While it's recording, cut/insert the columns in the order you want within the second sheet
Once done, click stop recording
Now you have a macro that you can open the rest of the pages, and it will repeat your re-ordering. Open each sheet and click View Macros, then run the one you just created. If you save the file, it will save the macro as well.
EDIT: Excellent point by #horaciux, be sure to save the entire workbook before running a macro, since there is no undo.