Need to copy & paste from several different sheets into one sheet vertically - vba

I'm attempting to write a macro that will copy a range of cells from a sheet, paste them into a sheet ("Bulksheet") that will contain all pasted data, then move on to the next tab after the first sheet. This needs to be done for 40+ tabs. Luckily, the data is in the same place in each tab, including the Bulksheet tab.
I can easily get this to apply to one tab, but returning to the first active tab and then moving on to the next is giving me no end of trouble.
Ex. code (shortened to the crucial bit). At the bottom where Next is would be where I need to move to the next sheet and do the same function, returning to "Bulksheet" and pasting in the next empty cell in column C.:
Sub
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Range("C100:F103").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Bulksheet").Select
Range("D1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End Sub

Try looping through the sheets using an index value instead.
Sub
Dim i as integer
For i = 1 to worksheets.count
sheets(i).Activate
if activesheet.name <> "Bulksheet" then
Range("C100:F103").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Bulksheet").Select
Range("D1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
end if
Next
End Sub

Try this:
Sub CopyToBulksheet()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Bulksheet" Then
ws.Activate
Range("C1:F10").Copy
Sheets("Bulksheet").Select
Range("D" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
End Sub

Related

How to make data backup code with excel vba

I make loop code based only on macros, is there any other way that can be used? or at least a simple form of code I created.
Sub xx()
Dim nom As Long
Dim bck As Workbook
Dim I As Long
Windows("LP13.xlsm").Activate
Application.CutCopyMode = False
Sheets("Validasi").Range("T2:T10").Copy
Windows("backup.xlsx").Activate
Sheets("backup").Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("LP13.xlsm").Activate
Application.CutCopyMode = False
Sheets("Validasi").Range("V2:X11").Copy
Windows("backup.xlsx").Activate
Sheets("backup").Range("G1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("LP13.xlsm").Activate
Application.CutCopyMode = False
For I = 1 To nom
Sheets("Data").Range("A2:W" & I).Select
Next
Selection.Copy
Windows("backup.xlsx").Activate
Sheets("backup").Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
bck.Save
Application.Visible = False
bck.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
it does look difficult because there are too many repetitions. I want a simpler code in the backup to another workbook.
As for strategy part of your question. you can create file versions backup on save as in http://analystcave.com/excel-quick-versioning-excel-files/
As for macro part
1. I would try to simplyfie the code with variables. You don't need to activate any thing to copy data, this is just way macro recorder works.
The backup part is asking for extracting function to paste range.
I would name the ranges in "from" workbook so you don't hardcode rng.address in code.
Your macro is not complex so naming range will solve the issue and will give you "documentation" what you coping and where.
If needed you can create sheet with list of source / destination ranges to copy and than pass it to "backup manager"
My take to refactor you code
Option Explicit
Private Type LP13Backup
FileName As String ' ?path
Sht As String
Rng As String
End Type
Public Sub LP13_BuckupManager() 'yes I know ..Manager ;)
Dim From As LP13Backup
Dim Backup As LP13Backup
From.FileName = "LP13.xlsm"
From.Sht = "Validasi"
From.Rng = "A1:B1"
With From
Workbooks(.FileName).Worksheets(.Sht).Range(.Rng).Copy
End With
Backup.FileName = "backup.xlsx"
Backup.Sht = "Backup"
Backup.Rng = "F1"
CopyToBackup Backup
End Sub
Sub CopyToBackup(ByRef Backup As LP13Backup)
With Backup
Workbooks(.FileName).Worksheets(.Sht).Range(.Rng).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End Sub
Word of comment on your solution
For I = 1 To nom
Sheets("Data").Range("A2:W" & I).Select
Next
This is not efecive way to select all values in column. You can go down from first cell
Range(Range("F1"), Range("F1").End(xlDown)).Address
or go up as in https://stackoverflow.com/a/27066381/7385538
With ws
lastRowIndex = .Cells(.Rows.Count, "A").End(xlUp).row
End With

Code Cleanup for Combining Sheets

I do not have much experience with VBA but I will start by explaining my situation.
I have a workbook with 341 sheets. Each sheet is identical in layout in that they occupy the space A1:J48. I need to combine all of these into one sheet called "COMBINATION". The information of relevance is from A10:J48. I also need to have the cells from A1:J9 as they are the title which is shared across all the sheets.
What I did was write a code that copies A1:J48 for Sheet1 (to get the title and info) and pastes it into "COMBINATION" with the paste special as text, then a code that goes to Sheet2 and copies from A10:J48 and pastes it in the first empty cell in column A of "COMBINATION".
This brings me to my problem. I have realized that there must be an easier way of doing this instead of copying the code 339 more times for each of the sheets.
See below the code. It does what I want correctly but as mentioned, I would like to find a way to not do this 339 more times...
Sheets("Sheet1").Select
Range("A1:J48").Select
Selection.Copy
Sheets("COMBINATION").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Columns.AutoFit
Sheets("Sheet2").Select
Range("A10:J10").Select
Range("J10").Activate
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("COMBINATION").Select
NextFree = Range("A10:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
I would use code like the following:
Dim ws As Worksheet
Dim r As Long
'Copy A1:J9 from the first sheet
Worksheets("Sheet1").Range("A1:J9").Copy
WorkSheets("COMBINATION").Range("A1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'Now loop through every sheet (except "COMBINATION") copying cells A10:J48
r = 10 ' first sheet will be copied to row 10 in COMBINATION
For Each ws In Worksheets
If ws.Name <> "COMBINATION" Then
ws.Range("A10:J48").Copy
Worksheets("COMBINATION").Range("A" & r).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'Set pointer ready for next sheet
r = r + 39
End If
Next
'Set column widths
Worksheets("COMBINATION").Columns.AutoFit
If your sheets don't always have data in all 39 rows (10 to 48), replace r = r + 39 with
r = Worksheets("COMBINATION").Range("A" & Worksheets("COMBINATION").Rows.Count).End(xlUp).Row + 1
Put the repeating code into a loop (untested):
Dim i as Integer
For i=2 to 341
Sheets(i).Select
Range("A10:J10").Select
Range("J10").Activate
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("COMBINATION").Select
NextFree = Range("A10:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next i
Range.PasteSpecial xlPasteValues is convenient but slow. It is much faster to define your 'Target' range to be the same size as your source range and do a direct assignment.
Sub CombineData()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Target As Range
With Worksheets("COMBINATION")
.Range("A1:J9").Value = Worksheets("Sheet1").Range("A1:J49").Value
For Each ws In Worksheets
If ws.Name <> .Name Then
Set Target = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
Target.Resize(39, 10).Value = ws.Range("A10:J48").Value
End If
Next
End With
Application.ScreenUpdating = True
End Sub

Calculate, Copy and Paste to a given value in VBA

I am fairly new to VBA. I am trying to automate iterations based on the no. of iterations specified in cell "E2". I want excel to Autofill down column A from cell "A4" to the value of cell "E2" e.g if E2 = 100, Excel will autofill series 1,2,3...down to 100.
I then want excel to continuosly calculate the value of cell "B2" then copy and paste each result down column B, starting at "B4" and stops at the value of iterations "E2"
I have the following code for the "Autofill"
Sub Monte3()
Dim srcRange As Range
Dim destRange As Range
Range("A5:A1000000").ClearContents
Set srcRange = ActiveSheet.Range("A4")
Set destRange = ActiveSheet.Range("A4:A103")
srcRange.AutoFill destRange, xlFillSeries
End Sub
I have recorded the following Macro for copy paste
Sub Macro10()
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
What's the easiest way to do this?
A nice For Each Next Loop should work. See the code below. I took some guesses on some of the range references based on what you wrote above, but you should be able to modify it easily to suit your needs.
Sub Monte3()
Dim srcRange As Range, cel As Range
Dim wks As Worksheet
Set wks = Sheets("Sheet1") 'replace Sheet1 with your sheet name
With wks
.Range("B5:B1000000").ClearContents
Set srcRange = .Range("B4:B" & .Range("E2").Value + 4) 'will plug the number in from E2 as the row and adds 4 since you are starting at row 4
For Each cel In srcRange
With .Range("B2")
.Calculate
.Copy
End With
cel.PasteSpecial xlPasteValues
Next
End With
End Sub

copying each row of an excel workbook to another excel workbook using VBA

I have a input workbook, from which I will copy first row and paste it in another excel workbook (wbET). This I have to do for the number of rows in my input workbook.
I have code for first row. I have to do it for all the rows. can any one help me out
code:
Option Explicit
Dim wbIP As Workbook
Dim wbJT As Workbook
Dim wbET As Workbook
Dim mypathET As String
Dim mypathJT As String
Dim mypathIP As String
Dim vals As Variant
Sub tool()
mypathET = "C:\Documents and Settings\madinenih\Desktop\PremiumCalcutionTool"
mypathJT = "C:\Documents and Settings\madinenih\Desktop\Japancalculationtool"
mypathIP = "C:\Documents and Settings\madinenih\Desktop\A01"
'
'Set wbJT = Workbooks.Open(Filename:=mypathJT)
Set wbIP = Workbooks.Open(Filename:=mypathIP)
wbIP.Activate
'Rows("1:1").Select
'Selection.Copy
wbIP.Sheets("A01").Range("A1:IU1").Copy
Set wbET = Workbooks.Open(Filename:=mypathET)
wbET.Activate
wbET.Sheets("Input file data").Range("A3:IU3").PasteSpecial
'wbET.Activate
Application.Run (wbET.Name & "!run1")
Call Createexcels
wbIP.Activate
'Rows("1:1").Select
'Selection.Copy
wbIP.Sheets("A01").Range("A1:IU1").Copy
Set wbJT = Workbooks.Open(Filename:=mypathJT)
wbJT.Activate
wbJT.Sheets(2).Range("A5:IU5").PasteSpecial
'Application.Run (wbJT.Name & "!run1")
Call openexcel
Call compare
End Sub
Sub Createexcels()
Dim NewBook As Workbook
vals = "test"
Set NewBook = Workbooks.Add
NewBook.SaveAs Filename:=vals
'Workbooks("Whatever.xlsx").Worksheets("output").Range("A1:K10").Copy
'NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
' NewBook.Worksheets("Sheet1").Activate
wbET.Activate
wbET.Sheets("Calculation").Range("L2:L41").Copy
NewBook.Worksheets("Sheet1").Activate
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wbET.Activate
wbET.Sheets("Calculation").Range("L44:L61").Select
Application.CutCopyMode = False
Selection.Copy
Windows(vals).Activate
Range("A44").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wbET.Activate
wbET.Sheets("Calculation").Range("L64:L69").Select
Application.CutCopyMode = False
Selection.Copy
Windows(vals).Activate
Range("A63").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wbET.Activate
wbET.Sheets("Calculation").Range("L72:L81").Select
Application.CutCopyMode = False
Selection.Copy
Windows(vals).Activate
Range("A70").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").EntireColumn.AutoFit
NewBook.Save
End Sub
You need to loop through all of the rows in your Input worksheet. To start you need to get the last used row in our input sheet.
' use this in your loop. It looks like you are starting on row 3 of your input sheet.
Dim LastRow as Long
LastRow = Activesheet.Cells(Activesheet.Rows.Count, 2).End(xlUp).Row
Dim i as Long
For i = 3 to LastRow
' Code to copy each row goes here
' You will need to change how you are referencing your range
wbET.Sheets("Input file data").Range("A" & i & ":IU" & i).PasteSpecial
Next i
you need to find the last row and last column
using last row and column as reference, you can make the copy paste method easily

Running a macro on worksheets with a specified name

I am trying to write a macro which pastes over the formulae within certain-named worksheets with their values, thereby making them exportable. I have successfully got the macro to dupe and rename the worksheets, but can't get the copy/paste to run on them as I would like.
Currently my macro copies all visible worksheets except one specified ("Dashboard") and then renames them, replacing " (2)" with "_VARIABLES". So far so good. It is then supposed to overwrite formulae in the newly created worksheets with values; this part does not work.
Here is the entire code:
Private Sub testestssss()
Dim ws As Worksheet
'Copy all visible worksheets except "Dashboard" to the end
For Each ws In Sheets
If ws.Name = "Dashboard" Then
Else
If ws.Visible Then ws.Copy after:=Worksheets(Worksheets.Count)
End If
Next
'Rename all "wk * (2)" sheets to "wk *_VARIABLES"
For Each ws In Sheets
If ws.Name Like "* (2)" Then
ws.Name = Replace(ws.Name, " (2)", "_VARIABLES")
End If
Next
'Overwrite all "wk *_VARIABLES" formulae with values
For Each ws In Sheets
If ws.Name Like "*_VARIABLES" Then
Columns("A:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
End Sub
So all the above works up until the 'overwrite all "wk *_VARIABLES" formulae with values' part. That appears to be ineffective.
Any help will be gratefully appreciated!
Thank you.
You keep selecting the column of the active sheet. This should do what you expect:
For Each ws In Sheets
If ws.Name Like "*_VARIABLES" Then
ws.Select
Columns("A:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
Alternatively, you can simply write this (no need to select and it runs a bit faster without them):
For Each ws In Sheets
If ws.Name Like "*_VARIABLES" Then
ws.Columns("A:B").Copy
ws.Columns("A:B").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Next
And finally to save a few keystrokes:
For Each ws In Sheets
If ws.Name Like "*_VARIABLES" Then
With ws.Columns("A:B")
.Copy
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End If
Next
And don't forget to add the following statement after the copy/paste section:
Application.CutCopyMode = False
to keep things clean.