I include some code in my project and I have something I do not understand. My With loop doesn't works.
My goal is to create new sheet from a specific cell B16=House and other new sheet for each cells contains PRIVATE word.
Example:
When user click on button:
- One new sheet created with title=Value of B16 just after my first sheet (name MyFirstSheet)
- Some other sheets created for each cells values contains word PRIVATE, just after the previous sheet.
So the result will be MyFirstSheet, House, Test1PRIVATE, Test2PRIVATE....
Sub NewSheetFromTemplate()
Dim SearchRange As Range, c As Range
Dim sht As Worksheet
'New sheet for a specific cell
Sheets("TEMPLATE").Copy After:=Sheets("MyFirstSheet")
ActiveSheet.Name = Sheets("MyFirstSheet").Range("B16").Value
'New sheet for each cell contains PRIVATE
With ThiwWorkbook
Set SearchRange = ActiveSheet.Range("B16:D70")
For Each c In SearchRange
If Right(c.Value, 2) = "PRIVATE" Then
Sheets("TEMPLATE").Copy After:=Sheets("MyFirstSheet")
Sheets("MyFirstSheet").Name = c.Value
End If
Next c
End With
End Sub
The problem is: My first sheet is well created (so i have MyFirstSheet, House, created) but not others sheet for each cell contains "PRIVATE"
Excel say ERROR 1004, and created a sheet in title TEMPLATE (2)
If I understand the question correctly then you merely need to change the line
If Right(c.Value, 2) = "PRIVATE" Then
to
If UCase(Right(c.Value, 7)) = "PRIVATE" Then
That's because the length of the word "private" is 7 characters and not 2. Furthermore, I am using UCASE to ensure that it will also find a match if private is written with different caps.
Thank you #Fabrizio and #Ralph for your assistance and explanation.
My final code:
Sub NewSheetFromTemplate()
Dim SearchRange As Range, c As Range
Dim sht As Worksheet
'New sheet for each value contain "PRIVATE"
With ThiwWorkbook
Sheets(1).Select
Set SearchRange = ActiveSheet.Range("A2:C70")
For Each c In SearchRange
If Right(c.Value, 7) = "PRIVATE" Then
Sheets("TEMPLATE").Copy After:=ActiveSheet
ActiveSheet.Name = c.Value
End If
Next c
End With
'New sheet for a specific cell: A2
Sheets(1).Select
Sheets("TEMPLATE").Copy After:=ActiveSheet
ActiveSheet.Name = Sheets(1).Range("A2").Value
'Show OK message
Sheets(1).Select
MsgBox "OK, all sheets well created. Please fill out next sheet"
End Sub
Related
Im wondering how i could create an Excel VBA that makes new Sheets and takes the names from a column with the range A2:A100 and only creates sheets if these cells arent empty.
My Sheet with the names looks something like this :
Variant | Title | Number
V1 Test1 1.1
V2 Test2 2.1
This means, that new Sheets with the names V1 & V2 should be created.
Furthermore i would want them, if possible, to have the exact same Content
A1 : productnumber A2 : amount
EDIT
Used this code now in Order to create the Sheets :
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("A10")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub
Changed "Summary" to my Sheets Name and adjusted the Range. As mentioned, i want the file to create Sheets based on the cell contents of A2:A100 only if the cell contains anything at all. Furthermore i am still not able to set the Contents of the new Sheets that are created
You have the basic method nailed, just added a check that the cell contains something and used a worksheet variable for the new sheet which is easier to use if you need to do things to it.
I don't know what you mean when you say you are "not able to set the Contents of the new Sheets"?
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range, ws As Worksheet
Set MyRange = Sheets("Summary").Range("A2:A100")
For Each MyCell In MyRange
If Len(MyCell) > 0 Then
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'creates a new worksheet
ws.Name = MyCell.Value ' renames the new worksheet
ws.Range("A1:D1").Value = Array("Artikelnummer", "Menge pro Schrank", "Anzahl Schränke", "Menge Gesamt")
End If
Next MyCell
End Sub
I have two main sheets in excel with other multiple sheets..
-> "Control sheet" and "Target sheet" for performing Loop
Control Sheet is with a Range (in column) on which to apply loop and next to the range are cell refernces to be used for "Target sheet".
The Target sheet has a Table named "Hyp_table" and shall be pasted in same "Target sheet" in a number of places, the refernce of which shall be read from the column next to the Range on which loop is to be perfomred on control sheet.
The objective is as follows
For each value in Range in control sheet, if the value in range is 1, then move to the target sheet, copy the "Hyp_table", and paste it on the cell number that is existent in column next to the Range on which loop is perfomred.
I have used the following code but it is not working:
Sub Testing()
Dim rng As Range, cell As Range
Set rng = Sheets("Control").Range("C5:C10")
For Each cell In rng
If cell = "1" Then
'Moving to my target sheet
Sheets(Sheets.Count).Select
ActiveSheet.Previous.Select
'Copying my table
Application.Goto "Hyp_Table"
Selection.Copy
'Selecting my cell on "Target sheet" based on value in "Control sheet"
ActiveSheet.Range(Sheets("Control").cell.Offset(, 1)).Select
'Pasting the table where the cell is selected as above
ActiveSheet.Paste
Application.CutCopyMode = False
Else
End If
Next cell
End Sub
Can anyone help me with the code.
First thing first - avoid using ActiveSheet, Application.GoTo and Selection. In every case.
How to avoid using Select in Excel VBA
Second thing second - avoid declaring variables with names like Cell and Range, because these names are special and they are used by the VBEditor.
Third thing third - try the code below - it will probably not work, because I did not understand what exactly is the offset, but it declares a sheetName and it uses it later. It is a good practice:
Option Explicit
Sub Testing()
Dim rng As Range
Dim myCell As Range
Dim sheetName As String
Set rng = Sheets("Control").Range("C5:C10")
For Each myCell In rng
If myCell = 1 Then
Worksheets(Worksheets.Count - 1).Range("Hyp_Table").Copy
sheetName = Worksheets("Control").Cells(1, 1)
Worksheets(sheetName).Paste
Application.CutCopyMode = False
End If
Next myCell
End Sub
I've been trying to get the code to work for the past week with no luck. I tried various modifications, which ends up giving different error codes.
The first Error I was getting was with Set rng = Intersect(.UsedRange, .Columns(2))
Object doesn’t support this property or method
So then I changed this to just going through the entire column just to see if it would work : Set rng = Range("B:B"), when I do that then it reads through and I get an error for Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value) with the error code:
run time error 1004 Sorry we couldn’t find 24 James.xlsx
Is it possible it was moved, renamed or deleted?
I believe that this line of the code is assuming that the hyperlink should open a different workbook with that name, however this is not the case. The hyperlink on the summary sheet links through to other sheets on the same master workbook, only the templates are on a separate book.
So to overcome this I tried changing this line as well and ended up with the code below, which manages to open the template workbook, and copy just the tab name onto the first sheet and then gives an error for the following line TemplateBook.Sheets("Red").Copy ActiveSheet.Paste, saying
subscript out of range
Sub Summary()
Dim MasterBook As Workbook
Set MasterBook = ActiveWorkbook
With MasterBook
Dim rng As Range
Set rng = Range("B:B")
End With
Dim TemplateBook As Workbook
Set TemplateBook = Workbooks.Open(Filename:=" C:\Users\Desktop\Example template.xlsx")
Dim cell As Range
For Each cell In rng
If cell.Value = "Red" Then
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
TemplateBook.Sheets("Red").Copy ActiveSheet.paste
ElseIf cell.Value = "Blue" Then
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
TemplateBook.Sheets("Blue").Copy ActiveSheet.paste
End If
Next cell
End Sub
I tried several more variations but I just can’t get it to copy the correct template, switch back to the master workbook sheet, follow through the link to correct sheet in the same master workbook, and paste the template.
A few comments about the modifications I made to your code:
Instead of using the entire Column B, try to use only cells in Column B that have values inside them.
Try to avoid using ActiveWorkbook, if the code lies in the same workbook then use ThisWorkbook instead.
When you set a Range, fully qualify it by stating the Workbook and Worksheet, as in : Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row).
I replaced your 2 Ifs with Select Case, as they the result in both is the same, and it will also allow you more flexibility in the future to add more cases.
When you copy an entire sheet with TemplateBook.Sheets("Red") and paste it to another Workbook, the syntax is TemplateBook.Sheets("Red").Copy after:=Sht.
Code
Option Explicit
Sub Summary()
Dim MasterBook As Workbook
Dim Sht As Worksheet
Dim Rng As Range
Set MasterBook = ThisWorkbook '<-- use ThisWorkbook not ActiveWorkbook
Set Sht = MasterBook.Worksheets("Sheet3") '<-- define the sheet you want to loop thorugh (modify to your sheet's name)
Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row) '<-- set range to all cells in column B with values
Dim TemplateBook As Workbook
Set TemplateBook = Workbooks.Open(Filename:="C:\Users\Desktop\Example template.xlsx")
Dim cell As Range
For Each cell In Rng
Select Case cell.Value
Case "Red", "Blue"
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here
TemplateBook.Sheets(cell.Value).Copy after:=Sht '<-- paste after the sheet defined
Case Else
' do something if you have other cases , not sure it's needed
End Select
Next cell
End Sub
Edit 1: to copy>>paste contents of the sheet, use the loop below:
For Each cell In Rng
Select Case cell.Value
Case "Red", "Blue"
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here
Application.CutCopyMode = False
TemplateBook.Sheets(cell.Value).UsedRange.Copy
Sht.Range("A1").PasteSpecial '<-- paste into the sheet at Range("A1")
Case Else
' do something if you have other cases , not sure it's needed
End Select
Next cell
Edit 2: Create a new worksheet, and then rename it with the cell.Offset(0, -1).Value
TemplateBook.Sheets(cell.Value).Copy after:=Sht
Dim CopiedSheet As Worksheet
Set CopiedSheet = ActiveSheet
CopiedSheet.Name = cell.Offset(0, -1)
I have a workbook with multiple sheets. One sheet has 2 columns of data. This sheet is titled "Notes" while the rest of them have a title that matches values entered in range A1:A6 of the "Notes" sheet. Column B contains notes that must go on each respective sheet from column A.
For example, if the 2nd sheet in the workbook is titled "Gpu manufacturing" and the value in A1 of the "Notes" sheet is also "Gpu manufacturing," then I want value in cell B1 of the "Notes" to be entered into cell F1 of the "Gpu manufacturing" sheet.
Next, if the 3rd sheet in the workbook is titled "Tesla GPUs" and the value in A2 of the "Notes" sheet is also "Tesla GPUs," then I want value in cell B2 of the "Notes" to be entered into cell F1 of the "Tesla GPUs" sheet.
Rinse and repeat to keep pulling data from the "Notes" sheet into other sheets based on their name or title.
Here is what I have so far:
Sub example()
Dim wkSht As Worksheet
For Each wkSht In Sheets
For Each Cell In Sheets("Reporting").Range("B2:B200")
If Cell.Value = wkSht.Name Then
wkSht.Range("D15").Copy Destination:=Cell.Offset(0,1)
End If
Next Cell
Next wkSht
End Sub
Edit for BruceWayne:
this is what my VBA app shows:
You first wrote:
"For example, if the 2nd sheet in the WB is titled "Gpu manufacturing" and the value in A1 of the "Notes" sheet is also "Gpu manufacturing," then I want value in cell B1 of the "Notes" to be entered into cell F1 of the "Gpu manufacturing" sheet."
From which it derives the following code:
Sub Main()
Dim cell As Range
For Each cell In Worksheets("Notes").Range("A1:A6")
Worksheets(cell.Value).Range("F1") = cell.Offset(,1)
Next cell
End Sub
Then you wrote in a comment to BruceWayne answer:
"however it still does not return anything in the F2 cell of each sheet"
Which changes (from "F1" to "F2") the destination cell in sheets other than "Notes" where to paste its values from column "B"
Should this latter be the real case then just substitute:
Worksheets(cell.Value).Range("F1") = cell.Offset(,1)
with:
Worksheets(cell.Value).Range("F2") = cell.Offset(,1)
Finally you wrote in another comment to BruceWayne answer:
"this is just a test workbook to get a macro that works because in reality, i will need to use it on a workbook that has 700+ sheets to match to a column and return specific data for that sheet from the second column on the "Notes" sheet – William Crawford 1 hour ago"
Which is an entirely different thing
My code here answers your original question
Should your need have changed than post another question
Sub example()
Dim wkSht As Worksheet
Dim cel As Range
For Each wkSht In ActiveWorkbook.Worksheets
For Each cel In Sheets("Reporting").Range("B2:B200")
If cel.Value = wkSht.Name Then
wkSht.Range("D15").Copy Destination:=cel.Offset(0, 1)
End If
Next cel
Next wkSht
End Sub
Mainly, I added Acitveworkbook.Worksheets instead of just Sheets. This should make sure the active book is the one being run on. Also, make sure you have a sheet called "Reporting". If this doesn't work, let me know how so.
Also realize, it's going to loop through 200 cells, on each worksheet. Is that the most efficient way to do this? Are you doing that big loop because the value is somewhere in that range? Or you actually need to check each one? (I'm thinking a find might be better)
Edit: How's this one, I switched it after your comments:
Sub example2()
Dim wkSht As Worksheet
Dim cel As Range
Dim curShtName As String
For Each sht In ActiveWorkbook.Worksheets
sht.Name = Trim(sht.Name)
Next sht
For i = 1 To 6 ' Since we go from A1/B1 to A6/B6
curShtName = Worksheets("Notes").Cells(i, 1).Value
If curShtName <> "Notes" Then
Worksheets(curShtName).Cells(2, 6).Value = Worksheets("Notes").Cells(i, 2).Value
End If
Next i
End Sub
Edit: just realized this is basically what user3598756 did :P
Edit 3: Okay, first, make positive that the second code bit I added above is in a workbook module in the workbook with your sheets. This should work for you, it did for me:
Then after running it:
etc, etc.
Per your most recent comments:
Sub copyInfo()
Dim lastRow As Long
Dim notesWS As Worksheet
Set notesWS = ActiveWorkbook.Worksheets("Notes") ' This is the worksheet with the info. you want to copy over to other sheets
lastRow = notesWS.Cells(notesWS.Rows.Count, 2).End(xlUp).Row ' Assuming your Col. B has the most info
Dim myFacts() As Variant
myFacts = notesWS.Range(notesWS.Cells(1, 2), notesWS.Cells(lastRow, 2))
Dim i As Long
i = 1
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Notes" Then
ws.Cells(2, 6).Value = myFacts(i, 1) 'This loops through our Array that we created above.
i = i + 1
End If
Next ws
End Sub
I am quite new to Excel Macro and need some help to achieve the following task.
I have two sheets in the same workbook; one is the main sheet that can be edited, and the other one is to extract certain columns from the main sheet. Since the main sheet may have columns inserted or deleted, my approach is to input specific titles that I would extract to sheet 2 (blank sheet initially), look up/match these texts/column titles in sheet 1 (main sheet); then, copy the entire column under that match column title and paste it to sheet 2.
I have the following code, but errors still pop up. Since I am not quite familiar with Macro syntax, I am not so sure if this approach is applicable. I do appreciate any help, comment, or suggestion. Thanks in advance.
Private Sub CommandButton1_Click()
Dim i As Long
Dim j As Long
Dim r As Long
For i = 1 To 30
For j = 1 to 30
If Sheets(2).Cells(1, j).Value = Sheets(7).Cells(1, i).Value Then
For r = 2 To 1000
Sheets(2).Cells(r, j).Copy
Sheets(7).Cells(r, i).PasteSpecial Paste:=xlPasteFormats
Sheets(7).Cells(r, i).PasteSpecial Paste:=xlPasteValue
Next r
End If
Next j
Next i
End Sub
you'd better use Find() method of Range object to find values in a range
so you may want to use this code
Option Explicit
Private Sub CommandButton1_Click()
Dim f As Range, mainShtHeaderRng As Range, blankShtHeaderRng As Range, cell As Range
Dim mainSht As Worksheet, blankSht As Worksheet
Set mainSht = Worksheets("mainSht") '<--| set your "main" sheet
Set blankSht = Worksheets("blankSht") '<--| set your "blank" sheet
Set mainShtHeaderRng = mainSht.Rows(1).SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<--| set your header range in the "main" sheet
Set blankShtHeaderRng = blankSht.Rows(1).SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<--| set your header range in the "blank" sheet
For Each cell In blankShtHeaderRng '<--| loop through "blank" sheet headers...
Set f = mainShtHeaderRng.Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False) '<--|... and search them between the "main" sheet headers
If Not f Is Nothing Then '<--| if found...
Range(f, mainSht.Cells(mainSht.Rows.Count, f.Column).End(xlUp)).Copy '<--| copy "main" sheet corresponding column doqwn to its last non empty cell...
cell.PasteSpecial Paste:=xlPasteFormats '<--| ... and paste formats...
cell.PasteSpecial Paste:=xlPasteValues '<--| ... and values to "blank" sheet current header column
End If
Next cell
End Sub