im stuck at a vba problem.
i want to copy some cells from worksheet to another
first i go through all worksheets begin with "IT*"
For Each ws In wb.Worksheets
If ws.Name Like "IT*" Then
ws.Select
Call transfer
End If
Next ws
then call transfer
Sub transferAP()
'
' transferAP Makro
'
Dim strSheetName As String
strSheetName = ActiveSheet.Name
Sheets(strSheetName).Select
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A3")
Worksheets(strSheetName).Range("E9").Copy Worksheets("Berechnung_Personal").Range("B3")
Worksheets(strSheetName).Range("G9").Copy Worksheets("Berechnung_Personal").Range("C3")
Worksheets(strSheetName).Range("G11").Copy Worksheets("Berechnung_Personal").Range("D3")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A4")
Worksheets(strSheetName).Range("E24").Copy Worksheets("Berechnung_Personal").Range("B4")
Worksheets(strSheetName).Range("G24").Copy Worksheets("Berechnung_Personal").Range("C4")
Worksheets(strSheetName).Range("G26").Copy Worksheets("Berechnung_Personal").Range("D4")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A5")
Worksheets(strSheetName).Range("E39").Copy Worksheets("Berechnung_Personal").Range("B5")
Worksheets(strSheetName).Range("G39").Copy Worksheets("Berechnung_Personal").Range("C5")
Worksheets(strSheetName).Range("G41").Copy Worksheets("Berechnung_Personal").Range("D5")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A6")
Worksheets(strSheetName).Range("M3").Copy Worksheets("Berechnung_Personal").Range("B6")
Worksheets(strSheetName).Range("O3").Copy Worksheets("Berechnung_Personal").Range("C6")
Worksheets(strSheetName).Range("O5").Copy Worksheets("Berechnung_Personal").Range("D6")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A7")
Worksheets(strSheetName).Range("M18").Copy Worksheets("Berechnung_Personal").Range("B7")
Worksheets(strSheetName).Range("O18").Copy Worksheets("Berechnung_Personal").Range("C7")
Worksheets(strSheetName).Range("O20").Copy Worksheets("Berechnung_Personal").Range("D7")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A8")
Worksheets(strSheetName).Range("M33").Copy Worksheets("Berechnung_Personal").Range("B8")
Worksheets(strSheetName).Range("O33").Copy Worksheets("Berechnung_Personal").Range("C8")
Worksheets(strSheetName).Range("O35").Copy Worksheets("Berechnung_Personal").Range("D8")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A9")
Worksheets(strSheetName).Range("U3").Copy Worksheets("Berechnung_Personal").Range("B9")
Worksheets(strSheetName).Range("W3").Copy Worksheets("Berechnung_Personal").Range("C9")
Worksheets(strSheetName).Range("W5").Copy Worksheets("Berechnung_Personal").Range("D9")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A10")
Worksheets(strSheetName).Range("U18").Copy Worksheets("Berechnung_Personal").Range("B10")
Worksheets(strSheetName).Range("W18").Copy Worksheets("Berechnung_Personal").Range("C10")
Worksheets(strSheetName).Range("W20").Copy Worksheets("Berechnung_Personal").Range("D10")
Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A11")
Worksheets(strSheetName).Range("U33").Copy Worksheets("Berechnung_Personal").Range("B11")
Worksheets(strSheetName).Range("W33").Copy Worksheets("Berechnung_Personal").Range("C11")
Worksheets(strSheetName).Range("W35").Copy Worksheets("Berechnung_Personal").Range("D11")
It runs at all, but if there is another worksheet ( and there is another) named "IT*" it will replace the copied files cause of the non relative output cell destination.
I want to continue with the new worksheet data at the end of the last copied data.
Hope you get what im trying to explain.
I propose you the following refactoring of your code
Sub transferAP(sourceSht As Worksheet)
With Worksheets("Berechnung_Personal") '<--| reference target sheet
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '<--| reference its column A first empty cell after last not empty one)
sourceSht.Range("C3").Copy .Cells(1,1)
sourceSht.Range("E9").Copy .Cells(2,1)
sourceSht.Range("G9").Copy .Cells(3,1)
.... and so on: keep in mind that .Cells(1,1) syntax assumes the referenced range as the starting cell
End With
End With
End Sub
And your main sub will call it as follows:
transferAP ws
This is your new Main sub. It is basically unchanged from your earlier code, but I have specified Wb to be ThisWorkbook. You may like to specify another.
Sub Main()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim R As Long
Set Wb = ThisWorkbook
For Each Ws In Wb.Worksheets
If Ws.Name Like "IT*" Then
TransferAP Ws, R ' pass the Ws to the sub
End If
Next Ws
End Sub
In your TransferAP I have also specified ThisWorkbook as the workbook where the target worksheet "Berechnung_Personal" is found. Excel presumes the ActiveWorkbook if no specification is made. Note that ThisWorkbook needs not be the ActiveWorkbook. ThisWorkbook is the Workbook that contains the code. The ActiveWorkbook is the last workbook you looked at before switching to the VBE window or the workbook you activated using code thereafter.
Sub TransferAP(Ws As Worksheet, R As Long)
' 21 Mar 2017
Dim WsTarget As Worksheet
Dim Sources() As String ' List of source cells
Dim i As Integer ' index for Sources
Set WsTarget = ThisWorkbook.Worksheets("Berechnung_Personal")
If R = 0 Then R = 3 ' row 3 is the first row to use
Sources = Split("E9,E24,E39,M3,M18,M33,U3,U18,U33", ",")
For i = 0 To UBound(Sources)
With WsTarget
.Cells(R, 1).Value = Ws.Range("C3").Value
.Cells(R, 2).Value = Ws.Range(Sources(i)).Value
.Cells(R, 3).Value = Ws.Range(Sources(i)).Offset(0, 2).Value
.Cells(R, 4).Value = Ws.Range(Sources(i)).Offset(2, 2).Value
End With
R = R + 1
Next i
End Sub
The TransferAP returns the final value of R to the Main. So, when the next source worksheet is found R will continue counting from where it left off - I hope. I didn't test the loop.
Related
I'm trying to do a VlookUp with two seperate workbooks. The main workbook opens the supporting workbook right at the beginning like this:
Public Sub GetFile()
Dim MySourceSheet As Variant, wb As Workbook
'Opens window to choose file from
MySourceSheet = Application.GetOpenFilename(FileFilter:= _
"Excel Files (*.XLS; *.XLSX), *.XLS; *.XLSX", Title:="Select file to
retrieve data from.")
If MySourceSheet = False Then Exit Sub
Set wb = Workbooks.Open(MySourceSheet)
End Sub
Throughout the module I reference the document a few times, and then there is this part were the error occurs.
Private Sub VlookupToBeReviewed()
Dim LastColumn As Long
Workbooks("09_PR Status Custodians.xlsm").Activate 'change name
'inserts new column
With Sheets("Prio_Custodians")
LastColumn = Cells(2, .Columns.Count).End(xlToLeft).Column 'change row! 'defines last column
For i = LastColumn To LastColumn Step -2 'moves two columns to the left
.Columns(i).Insert
.Columns(i).ColumnWidth = 10
Next
End With
'puts in the date
Cells(3, LastColumn).Value = Date
'sets up the variables for the vlookup
Dim rw As Long, col As Range
Dim twb As Workbook
'sets up the workbooks
Set twb = ThisWorkbook
Set col = Workbooks(MySourceSheet).Sheets("Documents to be reviewed").Range("A:B")
'vlookup function
With twb.Sheets("Sheet1")
For rw = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(rw, LastColumn) = Application.VLookup(.Cells(rw, 2).Value2, col, 2, False)
Next rw
End With
End Sub
Error:
Set col = Workbooks(MySourceSheet).Sheets("Documents to be reviewed").Range("A:B")
Spits out the
Run-time error '9' (Subscript out of range)
However, when I move my courser over MySourceSheet it shows the correct workbook as defined earlier in the module. If I put the name of the workbook manually with the .xls extension, it works all perfectly fine.I tried looking for an answer all over the web but nothing could quite fix it. I'd very much appreciate some help! :)
I need to copy the same worksheet X times (x = sheet2 row A) into a new workbook.
For each copy I need to:
1.Change a drop down to display the next value
2.Do a Refresh (Workbook is connected to a database which pulls different information based on the value of the drop down and is not automatically refreshed)
3.Copy just the values (no formulas)
Rename the sheet to the value of the drop down.
Save all of the copied worksheets into 1 workbook
My code (below) which is called on a button press currently saves the sheet X times based on sheet2 rowA (as intended).
It is missing steps 1,2,4 and 5
The code I have at the moment (called on button click)
Dim x As Integer '~~>Loop counter
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet2") '~~>Sheet with names
With WS
Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp) '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
x = Application.WorksheetFunction.Max(LastCellA.Row)
End With
For numtimes = 1 To x
ActiveWorkbook.Sheets("Sheet1").Copy _
After:=ActiveWorkbook.Sheets(Worksheets.Count)
'~~>Copy values only
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next
Still... I'm not sure of the point that you "Import" different values based on a drop down. That may be a different macro for loding the data. Then you need to call that macro instead of the .RefreshAll.
Sub test()
Dim uRow As Long, lRow As Long, i As Long
Dim wb As Workbook, ws As Object
With ThisWorkbook
Set ws = .Sheets("Sheet2")
With ws
uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set wb = Workbooks.Add
For i = uRow To lRow
.Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
End With
End Sub
EDIT:
If you get trouble with the Sheet2 Column A List (cus it contains empty cells resulting of formulas) you may try a different approach:
Sub test()
Dim wb As Workbook, ws As Worksheet
Dim xVal As Variant
With ThisWorkbook
Set ws = .Sheets("Sheet2")
Set wb = Workbooks.Add
For Each xVal In Intersect(ws.Range("A:A"), ws.UsedRange).Value
If Len(xVal) Then
.Sheets("Sheet1").Range("M1").Value = xVal
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
wb.Sheets(wb.Sheets.Count).UsedRange.Value = wb.Sheets(wb.Sheets.Count).UsedRange.Value
End If
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
End With
End Sub
Based on the code you provided, I believe this is what you are looking for.
It will loop through your list, copy sheet1 to the new workbook and name the sheet.
I am not sure what you want with looping through your dropdown list.
Sub Button1_Click()
Dim wb As Workbook, Bk As Workbook
Dim WS As Worksheet, sh As Worksheet
Dim LastCellA As Long, LastCellB As Range, c As Range
Dim LastCellRowNumber As Long
Dim x As Integer '~~>Loop counter
Set wb = ThisWorkbook
Set WS = wb.Worksheets("Sheet2") '~~>Sheet with names
Set sh = wb.Sheets("Sheet1")
With WS
LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
End With
Set Bk = Workbooks.Add
For Each c In LastCellB.Cells
sh.Range("M1") = c
sh.Copy After:=Bk.Sheets(Worksheets.Count)
With ActiveSheet
'~~>Copy values only
.UsedRange.Value = .UsedRange.Value
.Name = c
End With
Next c
End Sub
I am trying to dynamically generate a custom number of worksheets based on a template that we use regularly in excel using VBA.
I have created an "Overview" page where we can input a range which will be used to name the new worksheets but then would like to use a hidden "Master" worksheet to generate the content of these new worksheets.
My code below currently generates the correct number of pages based on the range AND copies our master template page but does not combine the two and leaves them in separate pages.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set masterSheet = ThisWorkbook.Worksheets("Master")
Set MyNames = Range("A1:A6").CurrentRegion ' load range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell range
masterSheet.Copy ThisWorkbook.Sheets(Sheets.Count) 'copy master template sheet
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
As you can see, the code generates both the named (blank) worksheets AND copies my master worksheet which defaults to naming as "Master()".
So we just need to replace this line:
Sheets.Add.Name = MyNewSheet.Value
with this line:
ActiveSheet.Name = MyNewSheet.Value
Loop through the list and copy the sheet if the sheet does not already exist.
Sub CopyMaster()
Dim ws As Worksheet, sh As Worksheet
Dim Rws As Long, rng As Range, c As Range
Set sh = Sheets("Overview")
Set ws = Sheets("Master")
With sh
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
End With
For Each c In rng.Cells
If WorksheetExists(c.Value) Then
MsgBox "Sheet " & c & " exists"
Else:
ws.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = c.Value
End If
Next c
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
I have the following code:
Sub test()
Dim r As Range, rng As Range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Name = rng
Else
End If
Next rng
End Sub
This would go through the range in A6 to AXX and create a worksheets for different names. I somehow can't figure out however how to copy the content of every row into every worksheet created.
So I want all the Ticker changes being copied into the new created worksheet ticker changes.
I know there is some way with the following:
Range(Cells(rng, 1), Cells(rng, 10)).Copy
But I don't know how to paste those to different worksheet.
Can someone please advice or guide. Thanks
Also when I try to run this macro it sometimes says:
That name is already taken try a different one.
However there is no worksheet with that name.
You only need to reference/specify the sheet that you want to use.
Try this (I included an inputbox to correct the name of the sheet if it is already taken :
Sub test_Nant()
Dim r As Range, rng As Range, ws As Worksheet, aWs As Worksheet
Set aWs = ActiveSheet
Set ws = Worksheets.Add
On Error GoTo SheetRename
ws.Name = "Changes list"
GoTo KeepLooping
SheetRename:
ws.Name = InputBox("Choose another name for that sheet : ", , rng.Value)
Resume Next
KeepLooping:
With aWs
Set r = .Range(.Range("a6"), .Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 10)).Copy Destination:=ws.Range("A1")
Else
End If
Next rng
End With
End Sub
Scenario: A workbook will have a variable number of worksheets, each with a variable number of populated cells, most commonly in Column A only but not necessarily. There is no header row. I want to combine all the worksheets into a single "master" worksheet, after which I will perform various shenanigans later on. What I have "mostly" works, but for some reason it leaves Row 1 blank, which I do not want. I suppose I could just delete the empty row, but that seems awfully cheesy and doesn't solve the underlying problem, which is that I don't understand why it's doing this.
Code:
Private Sub cmdFinalize_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim final As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wb = ActiveWorkbook
Set final = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
final.Name = "Final"
Set ws = wb.Worksheets(1)
colCount = ws.Cells(1, 255).End(xlToLeft).Column
For Each ws In wb.Worksheets
If ws.Index = wb.Worksheets.Count Then
Exit For
End If
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(65536, 1).End(xlUp).Resize(, colCount))
final.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next ws
End Sub
I assumed the Offset(1) was causing the problem, but removing it entirely causes the last row item of every worksheet to be overwritten by the first line of the next one when it all gets glued together on the 'Master' worksheet.
You need to use offset(1) only for second and after worksheet.
Following code use a flag to indicate the processing worksheet is first or not.
Private Sub cmdFinalize_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim final As Worksheet
Dim rng As Range
Dim colCount As Integer
Dim firstWorksheetFlag as boolean 'Flag to indicate the first worksheet is in process
firstWorksheetFlag = True ' Flag is true at begin
Set wb = ActiveWorkbook
Set final = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
final.Name = "Final"
Set ws = wb.Worksheets(1)
colCount = ws.Cells(1, 255).End(xlToLeft).Column
For Each ws In wb.Worksheets
If ws.Index = wb.Worksheets.Count Then
Exit For
End If
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(65536, 1).End(xlUp).Resize(, colCount))
If firstWorksheetFlag 'Offset(1) is not used.
final.Cells(65536, 1).End(xlUp).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
firstWorksheetFlag = False ' first worksheet has been processed, so next is not first.
Else 'second or later worksheet, so Offset(1) is used.
final.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count,rng.Columns.Count).Value = rng.Value
End If
Next ws
End Sub