I initially used the code (below) to compile data from 15 worksheets into a "template" sheet. It does this very well-- however, the needs of the workbook have changed somewhat.
Rather than copying this data into a relative location (the first empty cell in "template" column A), I now need to arrange the data into set locations, offset by 25 on each loop.
Ex:
wks 1 copy to A3 /
wks 2 copy to A28 /
wks 3 copy to A53 / etc
I have been trying to troubleshoot, but I'm still very weak when it comes to loops. Can anyone help me out?
Sub test()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If Not wks.Name = "template" Then
wks.Range("B6:B30").Copy
ActiveSheet.Paste
Destination:=Worksheets("template").Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next
End Sub
Try this. Assume the copied data is never more than 24 rows?
Sub test()
Dim wks As Worksheet, r As Range
Set r = Worksheets("template").Range("A3") 'initial paste range
For Each wks In ThisWorkbook.Worksheets
If Not wks.Name = "template" Then
wks.Range("B6:B30").Copy r
Set r = r.Offset(25) 'move down 25
End If
Next
End Sub
Related
I would like to copy a range in one sheet and paste it as a value in another sheet, but just in a specific range in the next available cell in column B. Starting from B4 to B23 only.
I changed some code I found online but it's not working for me in finding the next available row. After I run the macro the first time, when I run it again and again it does nothing, and it's not working in pasting only the values either.
I tried saving the file before running the Macro again, but still it's not working.
At the end, when the range in the Print sheet is full, I would like a message box asking me to select one of the printers (not the default) on one of my servers (specifying the server path in the code like \a_server_name) and print this Print Sheet only, or clear the records in the range in the Print Sheet, or save only the Sheet Print in a new file (SaveAs) to a location I can choose on one of my servers (specifying the server path in the code \a_server_name) or simply do nothing and end the sub.
Thank you.
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets(“Data”)
Set pasteSheet = Worksheets("Print”)
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B4:I23").End(xlUp).Offset(1,0)
.PasteSpecial.xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
This will set the values equal to each other without copying/pasting.
Option Explicit
Sub Testing()
Dim wsC As Worksheet: Set wsC = ThisWorkbook.Sheets("Data")
Dim wsP As Worksheet: Set wsP = ThisWorkbook.Sheets("Print")
Dim LRow As Long
LRow = wsP.Range("B" & wsP.Rows.Count).End(xlUp).Offset(1).Row
wsP.Range("B" & LRow).Resize(wsC.Range("J11:Q11").Rows.Count, wsC.Range("J11:Q11").Columns.Count).Value = wsC.Range("J11:Q11").Value
End Sub
Modifying your code - and reducing to minimal example
Sub test()
Dim copySheet As Worksheet: Set copySheet = Worksheets("Data")
Dim pasteSheet As Worksheet: Set pasteSheet = Worksheets("Print")
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B" & pasteSheet.Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End Sub
From what i can gather, you want to copy 8 cells and paste all 8 cells to 20 rows, starting at B4. You are not clear on how you want to rerun the macro, it will just write over the data you just pasted.
The first code will copy the 8 cells into the 20 rows
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Range("B4:I23").PasteSpecial Paste:=xlPasteValues
End With
This second code uses a for loop to accoplish the same task, but it also will write over the previously pasted data.
Dim i As Long
With ThisWorkbook
For i = 4 To 23
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(i, 2).PasteSpecial Paste:=xlPasteValues
Next i
End With
If you want to be able to reuse the macro, you will have to modify the range to be copied that allows you to select the range you want to copy. Maybe a variable that allows a user input with a InputBox.
Edit:
Dim lRow As Long
lRow = Sheets("Print").Cells(Rows.Count, 2).End(xlUp).Row
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Edit #3
With ThisWorkbook
Dim lRow As Long
lRow = .Sheets("Print").Range("B" & Rows.Count).End(xlUp).Row
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
I have two template sheets (linked), I would like to create about 100 times of both, and rename them as per the list on sheet "Output-->>>" form cell A381. eg. tesco, tesco LL
The below code doesnt work, can anyone help please?
Sub makeSheets()
Dim sh1 As Worksheets, sh2 As Worksheet, c As Range
Set sh1 = Sheets(Array("Template", "Template LL"))
Set sh2 = Sheets("Output-->>>")
For Each c In sh2.Range("A381", sh2.Cells(Rows.Count, 2).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
Next
End Sub
Many thanks
I'm using this macro to copy columns A and B from all of my sheets into a new sheet named Master. What I notice is that entire sheets worth of information are missing in the master sheet and I can't figure out why. The format for my sheets is column A has a string of characters that follow this structure: M2,004,005,004,007,17,096,01:07:45,45 and column B is just a date such as 4/19/2017.
I have hundreds of these sheets in my workbook and each has 224 rows that I need to copy into a single master sheet. Could anyone help me figure out how to get this code to stop skipping sheets?
Thanks.
Sub CreateMaster()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Master"
Sheets(2).Activate
Range("A1:B1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1:B1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1:B1").Select
Selection.CurrentRegion.Select
Selection.Copy Destination:=Sheets(1).Range("A65536:B65536").End(xlUp)(2)
Next
End Sub
while searching for solutions online, I came across this macro that seems to do the same thing, but also seems to skip the exact same sheets as my macro does.
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object
variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
as a workaround, since only the most recent data is immediately pertinent, I worked around it, but deleting the first 150 sheets. that still left around 100 sheets for my macro to work on, but now the missing pieces of data seem to be there. I wonder if there's something about the quantity of sheets that is causing this to malfunction?
Comments may not get it across correctly. Restructure your loop (and add the variables mentioned).
Dim x as Long
Dim thisSht as Worksheet
For x = 1 to wrk.Worksheets.Count
set thisSht = wrk.Worksheets(x)
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = thisSht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next x
I have a workbook with over 50 worksheets. I would like to copy the name of each worksheet into a cell of that particular workbook. I can do it for one sheet at a time using a macro with the following VBA code:
Range("B1") = ActiveSheet.Name
But when I try to apply the macro to several worksheets at a time, it fails. I would like it to get the names of the first 30 worksheets only.
Avoid relying on the ActiveSheet property to identify the worksheet you want to process. The With ... End With statement can readily provide the worksheet and help retrieve the Worksheet .Name property.
Sub name_Worksheets()
Dim w As Long
For w = 1 To 30
With Worksheets(w)
.Cells(1, 2) = .Name
End With
Next w
End Sub
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
My Understanding is you want to 1) Go through first 30 sheets of your workbook and 2) Paste the sheet name into cell B1.
Sub PasteSheetNameInB1()
For i = 1 To 30 '(1 to 30 because you said " I would like it to get the names of the first 30 worksheets only.")
ActiveWorkbook.Sheets(i).Select 'Iterates through first 30 sheets
Range("B1") = ActiveSheet.Name 'Pastes Sheet name into B1
Next i
End Sub
You can use this code:
For i = 1 To 30
Sheets(i).Range("B1").Formula = "=MID(CELL(""filename"",A1),FIND(""]"",CELL(""filename"",A1))+1,255)"
Next
Now if you change the name of any worksheet, You don't need to run the macro again, the formula in Rnage("B1") will display the new name.
So with this code, that you'll paste in the destination workbook,
you'll just need to change :
workbook_to_scan's Name and
Sheet's name in which to paste the names
to fit your needs!
Sub test_johnB()
Dim wB1 As Workbook, _
wB2 As Workbook, _
wSDest As Worksheet, _
wS As Worksheet, _
i As Integer
Set wB1 = ThisWorkbook
Set wB2 = Workbooks("workbook_to_scan's Name")
Set wSDest = wB1.Sheets("Sheet's name in which to paste the names")
i = 0
For Each wS In wB2.Sheets
wSDest.Range("B1").Offset(i, 0) = wS.Name
Next wS
End Sub
I have this code which appends data from three worksheets to a summary sheet, however on execution it is taking 12 of the 13 rows from sheet 1 and 2 and thirteen from sheet 3 to the summary I also would like this to work by sending to a summary sheet in a different workbook
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("D2:D6, D8:D15").Copy
Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(0, 0).PasteSpecial (xlPasteValues)
End If
Next ws
End Sub
Change Offset(0,0) to Offset(1,0). What's happening is not that it's copying 12 rows, but rather that the subsequent blocks are being pasted starting at the end of the previous block. That is, the first block is pasted into D1:D13, and the second block is pasted into D13:D26. By using Offset(1,0), the second block will be pasted starting with the first empty cell (that is, D14).
You can place the results in a new workbook simply by creating it in the code and referring to it in the paste, for example:
Option Explicit
Sub SummurizeSheets()
Dim ws As Worksheet
Dim currentWB As Workbook: Set currentWB = ActiveWorkbook
Dim newWB As Workbook: Set newWB = Application.Workbooks.Add
newWB.Worksheets(1).Name = "Summary"
For Each ws In currentWB.Worksheets
ws.Range("D2:D6, D8:D15").Copy
With newWB.Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp)
If IsEmpty(.Value) Then
.PasteSpecial (xlPasteValues)
Else
.Offset(1, 0).PasteSpecial (xlPasteValues)
End If
End With
Next ws
End Sub
EDIT updated to paste into the first empty cell in column, even if that is row 1.