I'm new in Excel VBA. I want to insert number of cells based on a cell value.
I have sheet1, i want to use b4 as a reference as to the number of sheets (which is a template) to be inserted.
Example, if value of b4 = 4, I'd like to copy the template sheet 4 times.
How do i do that in vba?
THANKS. :)
No magic, create them one by one in a loop, place each new one at the end. Edit: You want also to rename them 1, 2, 3, 4,.. so:
Sub CreateSheets()
Dim i As Long
With ThisWorkbook.Sheets
For i = 1 To Sheet1.Range("B4").Value2
.Item("Template").Copy After:=.Item(.Count)
.Item(.Count).Name = i
Next
End With
End Sub
Or something like this...
Sub CopyTemplate()
Dim ws As Worksheet, wsTemplate As Worksheet
Dim n As Integer, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1")
Set wsTemplate = Sheets("Template") 'Where Template is the name of Template Sheet, change it as required.
n = ws.Range("B4").Value
If n > 0 Then
For i = 1 To n
wsTemplate.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = i
Next i
End If
Application.ScreenUpdating = True
End Sub
Something like this should work:
Sub copySheets()
Dim i As integer
Dim n As integer 'the amount of sheets
n = Cells(4, 2).Value 'b4
For i = 2 To n
If ActiveWorkbooks.Worksheets.Count < n Then 'Makes sure the sheets exists
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
End If
ws1.Copy ThisWorkbook.Sheets(Sheets.Count) 'copy data
Next i
End Sub
Related
I have a noncontiguous range and I want whatever the user writes in each cell in the range to show up in a column in a table I made. In the first column of my table I'm having the program number each generated entry in the table when the user adds a value in one of the specified cells all the way up to 18. I renamed each cell in the range to be "Space_ (some number)". Even though I have written in three of the specified cells, my table only shows me the first value in the first specified cell.
Here is my code so far:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Integer
Dim rng As Range
Set rng = ws.Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
ws.Range("A13:A31,B13:B31").ClearContents
For i = 1 To 18
If Not IsEmpty("rng") Then
ws.Range("A12").Offset(1).Value = i
End If
Exit For
Next i
If Not IsEmpty("rng") Then
ws.Range("B12").Offset(1).Value = rng.Value
End If
End Sub
This should address the various issues I mentioned in my comment:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long
Dim rng As Range, r As Range
With ws
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
.Range("A13:B31").ClearContents
For Each r In rng.Areas
If Not IsEmpty(r) Then
.Range("A13").Offset(i).Value = i + 1
.Range("B13").Offset(i).Value = r.Value
i = i + 1
End If
Next r
End With
End Sub
A couple things here - Instead of trying to put all your named ranges into a Range, put them individually in an Array and cycle through them - If they're not blank, put the value into the cell.
Your .Offset is always going 1 below row 12, so that's why you're only seeing one row of data.
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long, j As Long
Dim rngarray As Variant
rngarray = Array("Space_7", "Space_10", "Space_13", "Space_16", "Space_19", "Space_22", "Space_25", "Space_28", "Space_31", "Space_34", "Space_37", "Space_40", "Space_53", "Space_56", "Space_59", "Space_62", "Space_65", "Space_68")
j = 12
ws.Range("A13:B31").ClearContents
For i = 0 To UBound(rngarray)
If ws.Range(rngarray(i)).Value <> "" Then
ws.Range("A12").Offset(j - 11).Value = i + 1
ws.Range("B12").Offset(j - 11).Value = ws.Range(rngarray(i)).Value
j = j + 1
End If
Next i
End Sub
I'd go as follows:
Sub test2()
Dim i As Integer
Dim rng As Range, cell As Range
With ThisWorkbook.Sheets("Sheet1")
.Range("A13:A31,B13:B31").ClearContents
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
For Each cell In rng.SpecialCells(xlCellTypeConstants).Areas
ws.Range("A12:B12").Offset(i).Value = Array(i + 1, cell(1, 1).Value)
i = i + 1
Next
End With
End Sub
Migrating data from one workbook to other. In new workbook I want only specific columns (that are almost 250). As the data in Master file, is inconsistent and not in same range, so how can I extract those 250 columns? As, I am new to VBA, I have tried the code below, it's working but I have to write long code for all that 250 columns? Any help will be greatly appreciated.
Sub Data_Migration()
Dim y As Workbook
Dim x As Workbook
Dim ws As Worksheet
Dim sh As Worksheet
Dim rng As Range
Set y = ThisWorkbook
Application.ScreenUpdating = 0
Set x = Workbooks.Open("file path")
'Column Q from master file with worksheet name cba is copied in new workbook with sheet name abc and pasted in column D
Set ws = y.Sheets("abc")
Set sh = x.Sheets("cba")
Set rng = sh.Range("Q2:Q11443")
rng.Copy
y.Sheets("abc").Range("D1").PasteSpecial xlValues
Application.CutCopyMode = False
Set ws = y.Sheets("abc")
Set sh = x.Sheets("cba")
Set rng = sh.Range("Z2:Z11443")
rng.Copy
y.Sheets("abc").Range("E1").PasteSpecial xlValues
Application.CutCopyMode = False
Set ws = y.Sheets("abc")
Set sh = x.Sheets("cba")
Set rng = sh.Range("AI2:AI11443")
rng.Copy
y.Sheets("abc").Range("F1").PasteSpecial xlValues
Application.CutCopyMode = False
x.Close
End sub
Paste the following code into a standard code module (by default 'Module1' but you can name it to your liking).
Sub Main()
' 21 Mar 2017
Dim WsS As Worksheet ' S = Source
Dim WbT As Workbook, WsT As Worksheet ' T = Target
Dim Cs As Long, Ct As Long ' Column numbers: Source & Target
Dim Clms As Variant
Dim i As Integer ' index for Clms
Application.ScreenUpdating = False
On Error GoTo ErrExit
' Source is the first worksheet in the active workbook:
Set WsS = ActiveWorkbook.Worksheets("Haseev")
Set WbT = Workbooks.Add(xlWBATWorksheet)
Set WsT = WbT.Worksheets(1)
WsT.Name = "Extract 250" 'name the target sheet
Clms = Array(1, 4, 8, 13) ' list column numbers < 17
For i = 0 To UBound(Clms)
CopyColumn WsS, WsT, Clms(i), Ct
Next i
For Cs = 17 To Columns("CHU").Column Step 9
CopyColumn WsS, WsT, Cs, Ct
'''' If Ct > 10 Then Exit For
Next Cs
ErrExit:
Application.ScreenUpdating = True
End Sub
Understand the code:-
Make the currently active workbook the "Source", meaning you must look at the workbook from which you are about to copy data. The code expects to find a worksheet by the name of "Haseev" in this workbook. Change the name in the code or change that entire line of code to
Set WsS = ActiveWorkbook.Worksheets(1)
That specifies the first worksheet in the workbook which makes good sense because a large workbook like yours isn't likely to have too many sheets.
The code will create a new workbook with a single sheet in it. It will name that sheet "Extract 250". Change the name in the code to something you prefer.
Next, the code will copy selected columns to the new workbook.
Clms = Array(1, 4, 8, 13)
You can specify which columns you want to copy - as many as you need, numbers separated by commas. If you don't want any, just leave the specification blank, like Clms = Array()
In the next loop every 9th column is copied, starting from column 17 to column "CHU". You can modify the "CHU". The line
'''' If Ct > 10 Then Exit For
is a leftover from my testing. You may like to use it for the same purpose. Remove the apostrophes which disable the code and the loop will stop copying after 10 columns have been copied to the new workbook.
You may notice that the above code doesn't contain any copy or paste. Instead, it calls the next sub which you should paste below the Main procedure you already copied above.
Private Sub CopyColumn(WsS As Worksheet, _
WsT As Worksheet, _
ByVal Cs As Long, _
Ct As Long)
' 21 Mar 2017
' Ct is a return Long
If Cs > 0 Then ' column number must be > 0
Ct = Ct + 1
WsS.Columns(Cs).Copy Destination:=WsT.Columns(Ct)
End If
End Sub
Basically, the Main procedure just manages the 250 plus times this sub will be called.
The output workbook will have a generic name given by Excel, like "Sheet1". You can save it under any name you wish or close it and make a new one next time you wish to look at it.
You need a For .. Next loop. Basically,
Dim C As Long
For C = 1 to 250
' enter repetitive code here
Next C
If C is your column number, you can use C as the column number instead of "A", "B", "C". Excel isn't very good at letters. It converts the A you type into 1, B to 2, C to 3 etc - up to 250.
However, it seems that you don't need consecutive columns. So, you create an array of the numbers you need.
Dim Arr As Variant
Arr = Array(1, 12, 16, 25, 32) ' list all your 250 columns.
Now, Arr(0) = 1, Arr(1) = 12, Arr(2) = 16 etc.
and you construct your loop to refer to these numbers.
Dim n As Integer
For n = 0 to Ubound(Arr) ' that the number of elements in Arr
C = Arr(n)
Debug.Print C ' this will write C in the immediate window
Next n
In this structure you can use C as the column number, like,
Set Rng = Sh.Range(Cells(3, C), Cells(11443, C))
Cells(3, C) specifies A3, if C = 1
PS Just occurred to me that you might need this, too:-
Range("ZH2").Column should return the column number for column "ZH"
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
I have 2 wb and need to copy value to another wb based on condition:
If the value in the column F of wb2 appears in column F of wb1, then I need to copy value in the column G of wb2 to column G of wb1. The code is below:
Dim LtRow As Long
Dim m As Long, n As Long
With wb2.Worksheets.Item(1)
LtRow = .Cells(.Rows.Count, "G").End(xlUp).Row
End With
With ThisWorkbook.Sheets.Item(2)
n = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
End With
For m = 1 To LtRow
With wb2.Worksheets.Item(1)
If .Cells(m, 6).Value = ThisWorkbook.Sheets.Item(2).Cells(m, 6).Value Then
.Rows(m).Copy Destination:=ThisWorkbook.Sheets.Item(2).Range("G" & n)
n = n + 1
End If
End With
Next m
I don't know why the code didn't work at all! Where is the problem in my code?
EDIT:
To see what your excel files look like wasn't an option for what you are trying to do. Especially because in you have many empty rows. Anyway, this works for me:
Sub CopyConditions()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim Wb1Ws2 As Worksheet
Dim Wb2Ws1 As Worksheet
Set Wb1 = ThisWorkbook
Set Wb1Ws2 = ThisWorkbook.Sheets("Differences")
'open the wb2
Dim FullFilePathAndName As Variant
Dim StrOpenFileTypesDrpBx As String
Let StrOpenFileTypesDrpBx = "xls (*.xls),*.xls,CSV (*.CSV),*.CSV,Excel (*.xlsx),*.xlsx,OpenOffice (*.ods),*.ods,All Files (*.*),*.*,ExcelMacros (*.xlsm),.xlsm"
Let FullFilePathAndName = Application.GetOpenFilename(StrOpenFileTypesDrpBx, 1, "Compare this workbook ""(" & Wb1.Name & ")"" to...?", , False) 'All optional Arguments
If FullFilePathAndName = False Then
MsgBox "You did't select a file!", vbExclamation, "Canceled"
Exit Sub
Else
Set Wb2 = Workbooks.Open(FullFilePathAndName)
Set Wb2Ws1 = Wb2.Sheets("Sheet1")
End If
Dim rCell As Range
Dim sCell As Range
'loop through each cell in column F until row30 because with the empty cells in the column we can't use Rows.count
For Each rCell In Wb1Ws2.Range(Wb1Ws2.Cells(1, 6), Wb1Ws2.Cells(30, 6)) 'Wb1Ws2.Cells(Wb1Ws2.Rows.Count, 6).End(xlUp))
'if the cell column F is equal to a cell in wb2 sheet1 column L
For Each sCell In Wb2Ws1.Range(Wb2Ws1.Cells(3, 12), Wb2Ws1.Cells(Wb2Ws1.Rows.Count, 12).End(xlUp))
If sCell = rCell Then
rCell.Offset(0, 1) = sCell.Offset(0, 1)
End If
Next sCell
Next rCell
End Sub
How does it go for you?
I have a header that starts in Column E and might go on for 100+ columns.
I am trying to change each column header to add a prefix (the name of the "tab" aka. worksheet) (ie. if Worksheet is called 'Beverage', I'd like each column header to be prefixed with "Beverage -")
I will be running script across multiple sheets, so am trying to find a way to reference the current sheet name.
Before: (For Worksheet "Beverage")
After: (For Worksheet "Beverage". Note: Columns don't need to be resized, just did it to demonstrate)
I've tried adapting code from this thread, however I can't get it to work.
Here is the code I have so far (non-working):
Sub Worksheet_Name_Prefix()
Dim columnNumber As Long, x As Integer
Dim myTab As ListObject
Set myTab = ActiveSheet.ListObjects(rows.Count, 1)
For x = 5 To rows.Count ' For Columns E through last header cell with value
columnNumber = x
myTab.HeaderRowRange(1, columnNumber) = ActiveSheet.Name
Next x
End Sub
Any suggestions on what's wrong with my code? Any help would be greatly appreciated.
I hope this help you...
Sub Worksheet_Name_Prefix_v2()
Dim h 'to store the last columns/header
Dim rngHeaders As Range 'the whole range with the headers from E1 to x1
Dim i 'just and index
Dim sht As Worksheet 'the sheet where you want the job done
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
Set rngHeaders = Range(Cells(1, 5), Cells(1, h)) 'the range with the headers E = column 5
'Cells 1 5 = E1
'Cells 1 h = x1 where x is the last column with data
Set sht = ActiveSheet 'the sheet with the data, _
'and we take the name of that sheet to do the job
For Each i In rngHeaders 'for each cell in the headers (every cells in row 1)
i.Value = sht.Name & " - " & i.Value
'set the value "sheet_name - cell_value" in every cell
Next i
End Sub
If you need any emprovement please tell me... I'm not sure if I get the real idea of what you need.
Edit #1
Use this in a regular module:
Option Explicit
Sub goForEverySheet()
Dim noSht01 As Worksheet 'store the first sheet
Dim noSht02 As Worksheet 'store the second sheet
Dim sht 'just a tmp var
Set noSht01 = Sheets("AA") 'the first sheet
Set noSht02 = Sheets("Word Frequency") 'the second sheet
appTGGL bTGGL:=False
For Each sht In Worksheets ' for each sheet inside the worksheets of the workbook
If sht.Name <> noSht01.Name And sht.Name <> noSht02.Name Then
'IF sht.name is different to AA AND sht.name is diffent to WordFrecuency THEN
'TIP:
'If Not sht.Name = noSht01.Name And Not sht.Name = noSht02.name Then 'This equal
'IF (NOT => negate the sentence) sht.name is NOT equal to noSht01 AND
' sht.name is NOT equal to noSht02 THEN
sht.Activate 'go to that Sheet!
Worksheet_Name_Prefix_v3 'run the code
End If '
Next sht 'next one please!
appTGGL
End Sub
Sub Worksheet_Name_Prefix_v3()
Dim h 'to store the last columns/header
Dim rngHeaders As Range 'the whole range with the headers from E1 to x1
Dim i 'just and index
Dim sht As Worksheet 'the sheet where you want the job done
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
Set rngHeaders = Range(Cells(1, 5), Cells(1, h)) 'the range with the headers E = column 5
'Cells 1 5 = E1
'Cells 1 h = x1 where x is the last column with data
Set sht = ActiveSheet 'the sheet with the data, _
'and we take the name of that sheet to do the job
For Each i In rngHeaders 'for each cell in the headers (every cells in row 1)
i.Value = sht.Name & " - " & i.Value
'set the value "sheet_name - cell_value" in every cell
Next i
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Debug.Print Timer
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub
Your code was not running because, you do not use this line sht.Activate you say, for every sheet in the workbook do this, but you not say to go to every sheet, and the the code run n times in the same sheet (as many sheets there in the workbook less two). But if you say, for every sheet do this, AND got to each of one of that sheets and do this (less that two sheets) you will get whay you want