I have merged cells across a certain range. The number of merged areas varies by worksheet, some have 2, some have 10. Once the new file is created and saved, all merged areas pull the text back into the first cell in the range. I am really trying to save an exact hard coded copy, with a different file name.
Here is the portion of code that is used to save values and then SaveCopyAs:
Sheets("Send").Visible = True
Sheets.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Dim thisWb As Workbook, d As Integer
Set thisWb = ActiveWorkbook
d = InStrRev(thisWb.FullName, ".")
'ActiveWorkbook.SaveAs Filename:=Left(thisWb.FullName, d - 1) & "-Prelims" & Mid(thisWb.FullName, d)
Sheets("Send").Visible = False
Dim newFileName As String
newFileName = Left(thisWb.FullName, d - 1) & "-Prelims" & Mid(thisWb.FullName, d)
thisWb.SaveCopyAs Filename:=newFileName
This seems like it should be easy but I haven't been able to find the answer here on SO or anywhere else.
Here is what your code should look like. This should be far more efficient for you
Let me know if anything is wrong:
Sub test()
Dim thisWb As Workbook, ws As Worksheet, d As Integer, lastRow As Long
Set ws = Sheets("Send")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'Finds the bottom populated row
With ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1)) 'This find the bottom of column A
.Value = .Value 'Change to text rather than formula
End With
Set thisWb = ActiveWorkbook
d = InStrRev(thisWb.FullName, ".")
Sheets("Send").Visible = False
Dim newFileName As String
newFileName = Left(thisWb.FullName, d - 1) & "-Prelims" & Mid(thisWb.FullName, d)
thisWb.SaveCopyAs Filename:=newFileName
End Sub
Related
I have few sheets in my Excel. I want this code to apply Some specific Sheet. Since I am not good at vba I am unable to do it. Please somebody help me. How do I add Sheet3 to 17 to this code so that code only run for these sheets.
Sub insertRowsSheets()
' Disable Excel properties before macro runs
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
' Declare object variables
Dim ws As Worksheet, iCountRows As Integer
Dim activeSheet As Worksheet, activeRow As Long
Dim startSheet As String
' State activeRow
activeRow = ActiveCell.Row
' Save initial active sheet selection
startSheet = ThisWorkbook.activeSheet.Name
' Trigger input message to appear - in terms of how many rows to insert
iCountRows = Application.InputBox(Prompt:="How many rows do you want to insert, starting with row " _
& activeRow & "?", Type:=1)
' Error handling - end the macro if a zero, negative integer or non-integer value is entered
If iCountRows = False Or iCountRows <= 0 Then End
' Loop through the worksheets in active workbook
For Each ws In ActiveWorkbook.Sheets
ws.Activate
Rows(activeRow & ":" & activeRow + iCountRows - 1).Insert
Range("A9").Select
Range("A8:C8").Select
Selection.Copy
Range("A9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("D8:J8").Select
Selection.AutoFill Destination:=Range("D8:J9")
Range("D8:J9").Select
Range("K8:L8").Select
Selection.Copy
Range("K9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("M8:T8").Select
Selection.AutoFill Destination:=Range("M8:T9")
Range("M8:T9").Select
Range("A8").Select
Next ws
' Move cursor back to intial worksheet
Worksheets(startSheet).Select
Range("A8").Select
' Re-enable Excel properties once macro is complete
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Update Worksheets
This should work the same way as before.
At least it should help you to figure out how to loop through an array of worksheet names instead of the worksheets collection.
I could not figure out the logic of copying and filling. Shouldn't you be filling as many rows as the user selected starting from the active row?
The Code
Option Explicit
Sub insertRowsSheets()
' Define Worksheet Names Array.
Dim wsNames As Variant ' Tab names, not code names.
wsNames = Array("Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", _
"Sheet8", "Sheet9", "Sheet10", "Sheet11", "Sheet12", _
"Sheet13", "Sheet14", "Sheet15", "Sheet16", "Sheet17")
' Declare object variables
Dim wb As Workbook
Dim ws As Worksheet
Dim RowsCount As Long
Dim ActiveRow As Long
Dim StartSheet As String
Dim i As Long
' Define workbook.
Set wb = ThisWorkbook ' The workbook containing this code.
' State activeRow
ActiveRow = ActiveCell.Row
' Trigger input message to appear - in terms of how many rows to insert
RowsCount = Application.InputBox(Prompt:="How many rows do you want to insert, starting with row " _
& ActiveRow & "?", Type:=1)
' Error handling - end the macro if a zero, negative integer or non-integer value is entered
If RowsCount = False Or RowsCount <= 0 Then Exit Sub
' Loop through the worksheets.
For i = LBound(wsNames) To UBound(wsNames)
With wb.Worksheets(wsNames(i))
.Rows(ActiveRow & ":" & ActiveRow + RowsCount - 1).Insert
.Range("A9:C9").Value = .Range("A8:C8").Value
.Range("D8:J8").AutoFill Destination:=.Range("D8:J9")
.Range("K9:L9").Value = .Range("K8:L8").Value
.Range("M8:T8").AutoFill Destination:=.Range("M8:T9")
End With
Next i
End Sub
' Loop through the worksheets in active workbook
For i = 3 To 17 Step 1 'This runs from the 3rd Sheet to the 17th irrespective of the name. Use array method if the sheets are mixed up
If WorksheetIDExists(i, ActiveWorkbook) Then
Set ws = ActiveWorkbook.Worksheets(i)
With ws
.Rows(activeRow & ":" & activeRow + iCountRows - 1).Insert '<- Kindly note that, if the active row is above A8, the whole script becomes a mess
.Range("A8:C8").Copy
.Range("A9").PasteSpecial Paste:=xlPasteValues
.Range("D8:J9").FillDown
.Range("K8:L8").Copy
.Range("K9").PasteSpecial Paste:=xlPasteValues
.Range("M8:T8").FillDown
.Range("A8").Select
End With
End If
Next i
Add this Function as well.
Function WorksheetIDExists(shtid As Integer, wb As Workbook) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Worksheets(shtid)
On Error GoTo 0
WorksheetIDExists = Not sht Is Nothing
End Function
I have 80 or so columns of data. I need just 21 columns.
In my output, I would like the 21 columns to be in a particular order. For example, I want the value from the cell AX2 from my source file to go to A2, BW2 to go to B2, etc.
The source data may differ from month to month and could have as little as 1 row of data or hundreds so I would like this to loop until no data is left.
I got a run time error 424 object required. I have only outlined the rules for two columns but will work on the rest when I get the proper set up.
Sub Macro1()
'
' Macro1 Macro
'
'
Sheet4.Select
Application.ScreenUpdating = False
row_count = 2
Do While Sheet2.Range("A" & row_count) <> ""
Range("AX2:AX1000").Select
Selection.Copy
ActiveWindow.ActivateNext
Range("A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ActivateNext
Range("BW2:BW1000").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ActivateNext
Range("B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
x = x + 1
ActiveWindow.ActivateNext
ActiveSheet.Next.Select
ActiveSheet.Next.Select
Loop
End Sub
I hope I didn't go too far. Try this subscript, it asks you to select a workbook, it will open the workbook, copy column B2 to last used Row on Column B, and paste it on the first workbook. Make sure to rename the CopyFromSheet and CopyToSheet on the code. Please read each line and try to understand what it is doing. Let me know if any questions.
Sub CopyPaste()
Dim openFile As FileDialog, wb As Workbook, sourceWb As Workbook
Dim CopyTo As String, CopyFrom As String
Dim lastRow As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set openFile = Application.FileDialog(msoFileDialogFilePicker)
openFile.Title = "Select Source File"
openFile.Filters.Clear
openFile.Filters.Add "Excel Files Only", "*.xl*"
openFile.Filters.Add "All Files", "*.*"
openFile.Show
If openFile.SelectedItems.Count <> 0 Then
Set sourceWb = Workbooks.Open(openFile.SelectedItems(1), False, True, , , , True)
CopyFrom = "CopyFromSheetName"
CopyTo = "CopyToSheetName"
lastRow = sourceWb.Sheets(CopyFrom).Cells(Rows.Count, "B").End(Excel.xlUp).Row
sourceWb.Sheets(CopyFrom).Range("B2:B" & lastRow).Copy 'You can copy this Row and the Next and add as many as you want to copy the Columns Needed
wb.Sheets(CopyTo).Range("B1").PasteSpecial xlValues
Application.CutCopyMode = xlCopy
Else
MsgBox "A file was not selected"
End If
Application.ScreenUpdating = True
End Sub
I suggest you separate the copy logic from the setup of which columns to copy. That way it will be much easier to manage the setup.
In this code I have hard coded to Columns Pairs. Alternatively, you could put that data on a sheet and read it in.
Sub Demo()
'declare all your variables
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSource As Range
Dim rDest As Range
Dim CP() As Variant 'Column Pairs array
Dim idx As Long
'Set up an array of Source and Destination columns
ReDim CP(1 To 21, 1 To 2) 'Adjust size to suit number of column pairs
CP(1, 1) = "AX": CP(1, 2) = "A"
CP(2, 1) = "BW": CP(2, 2) = "B"
'and so on
' Source and Destination don't have to be in the same Workbook
' This code assumes the Source (and Destination) worksbooks are already open
' You can add code to open them if required
' If the data is in the same book as the code, use ThisWorkbook
' If the data is in a different book from the code,
' specify the book like Application.Workbooks("BookName.xlsx")
' or use ActiveWorkbook
'Update the names to your sheet names
Set wsSource = ThisWorkbook.Worksheets("SourceSheetName")
Set wsDest = ThisWorkbook.Worksheets("DestSheetName")
' Notice that form here on the code is independent of the Sheet and Column names
'Loop the column pairs array
For idx = 1 To UBound(CP, 1)
'if the entry is not blank
If CP(idx, 1) <> vbNullString Then
'Get reference to source column cell on row 2
Set rSource = wsSource.Columns(CP(idx, 1)).Cells(2, 1)
'If that cell is not empty
If Not IsEmpty(rSource) Then
'If the next cell is not empty
If Not IsEmpty(rSource.Offset(1, 0)) Then
'extend range down to first blank cell
Set rSource = wsSource.Range(rSource, rSource.End(xlDown))
End If
'Get a reference to the destination range, from row 2, same size as source
Set rDest = wsDest.Columns(CP(idx, 2)).Cells(2, 1).Resize(rSource.Rows.Count)
'Copy the values
rDest.Value = rSource.Value
End If
End If
Next
End Sub
Objective: I'm trying to copy, find and paste data as per the find (that is Region).
Problem: I'm getting the desired output when I'm defining where to paste the data. But this is not what the macro is suppose to do. It's suppose to look for that Region name and then paste the data under the appropriate title and so on.
Here is what I've written so far:
Sub DataPasting()
ApplicationUpdating = False
Sheets("Sheet1").Range("I2:J2").Copy 'copy and pasting the data set from Sheet1
Sheets("Stories & Topics").Select
Dim RegionColumn As Long
Dim erow As String
RegionColumn = Application.WorksheetFunction.Match(Sheets("Raw").Range("H1"), Sheets("Stories & Topics").Range("A1:Z1"), False)
erow = ThisWorkbook.Worksheets("Stories & Topics").Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Worksheets("Stories & Topics").Paste (ThisWorkbook.Worksheets("Stories & Topics").Range("B" & erow + 1))
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ApplicationUpdating = True
End Sub
Note:
Sheet1 = Sheet from where the data is to be copied
Stories & Topics = Destination sheet where the data has to be pasted
I also tried Vlookup and Match but no use.
Thanks!
It's difficult to tell from your code exactly what you're doing but something like this should work:
Sub DataPasting()
Dim RegionColumn 'variant
Dim erow As Long
Dim shtRaw As Worksheet, shtSaT As Worksheet, shtOne As Worksheet
Set shtRaw = ThisWorkbook.Sheets("Raw")
Set shtSaT = ThisWorkbook.Sheets("Stories & Topics")
Set shtOne = ThisWorkbook.Sheets("Sheet1")
ApplicationUpdating = False
RegionColumn = Application.Match(shtRaw.Range("H1").Value, _
shtSaT.Range("A1:Z1"), 0)
If Not IsError(RegionColumn) Then
erow = shtSaT.Cells(Rows.Count, "B").End(xlUp).Row
shtSaT.Cells(erow, RegionColumn).Resize(1, 2).Value = shtOne.Range("I2:J2").Value
End If
ApplicationUpdating = True
End Sub
I use two workbooks (obviously based on the question:)), from the first one (as you will see in the code below) gets sorted by the data in column "B". The data in this column is just a number based on the month (11=November, December=12, etc.). For this question (and it will provide the answer for my other monthly workbooks), need to copy all the rows of data (columns A:AE) in column B to another workbook (which is already open), and paste the data into the empty row at the bottom. I have the sort part working fine. I am trying to add in the copy & paste function into the code, but can't get it to work. HELP!
Here is the code I have tried (but can't figure out how to get focus to the target workbook):
Sub Extract_Sort_1512_December()
' This line renames the worksheet to "Extract"
Application.ScreenUpdating = False
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("B" & LR).Value <> "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = “12” Then
Range(Cells(i, 1), Cells(i, 31)).Select
Selection.Copy
ActiveWorkbook(“Master File - Swivel - December 2015.xlsm”).Select
Worksheets(“Master”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
I have found this code below, but do not know how to insert it properly into my code above. The thing that makes me weary is that the workbooks are already open. The target workbook is located on our SharePoint site and I do not know how (or if) you can use VBA code to open it to your desktop.
Here is the other code:
Sub Demo()
Dim wbSource As Workbook
Dim wbTarget As Workbook
' First open both workbooks :
Set wbSource = Workbooks.Open(" ") ' <<< path to source workbook
Set wbTarget = ActiveWorkbook ' Workbooks.Open(" ") ' <<< path to destination workbook
'Now, transfer values from wbSource to wbTarget:
wbTarget.Sheets("Sheet1").Range("B2").Value = wbSource.Sheets("Sheet3").Range("H4")
wbTarget.Sheets("Sheet1").Range("B3").Value = wbSource.Sheets("Sheet3").Range("J10")
'Close source:
wbSource.Close
End Sub
I have modified your code slightly, but kept most of it as is.
I think the problem was related to the way in which you were trying to activate the workbook where the data was to be pasted. Normally the Activate command is used with workbooks, as opposed to Select. However, I bypassed the whole activation of the new workbook, because it would require you to then "re-activate" the original workbook before copying the next line. Otherwise you would be copying from the active workbook, which would now be the one to be pasted into. Please see the code - it should be fairly straightforward.
Sub Extract_Sort_1512_December()
Application.ScreenUpdating = False
' This line renames the worksheet to "Extract"
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Not Range("B" & LR).Value = "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "12" Then
' As opposed to selecting the cells, I just copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, I just paste the cells directly
With Workbooks("Master File - Swivel - December 2015.xlsm").Sheets("Master")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub
Hi alI am trying to copy data from a series of workbooks into a master file. The master file contains the spreadsheet names, and sheet names to loop through as strings and I have that process working fine. But now I need to match the names in column A and row 1 with the data in each worksheet and copy the cell including any comments. I had the vlookup working but it does not copy the comments. So I have tried to do a couple of match statements to find the cell column and row numbers but cannot seem to get it to work. Any ideas??
Sub GroupTwo()
Dim path As String
Dim i As Integer
Dim Dsheet As String
Dim wb As Workbook
Dim upi
Dim cmt As Comment
Dim iRow As Integer
Dim col As Integer
Dim lookrange As Range
Dim G2 As Worksheet
Dim colRange As Variant
Dim rowRange As Range
Dim rowCell As Variant
Dim colCell As Variant
Set lookrange = ThisWorkbook.Sheets("Lookups").Range(ThisWorkbook.Sheets("Lookups").Cells(3, 1), ThisWorkbook.Sheets("Lookups").Cells(11, 2))
Set G2 = ThisWorkbook.Sheets("Group_two")
Application.DisplayAlerts = False
upi = 2
coln = 2
For i = 60 To 61
path = ThisWorkbook.Sheets("Sheet7").Cells(1, i).Value
Dsheet = ThisWorkbook.Sheets("Sheet7").Cells(2, i).Value
Set wb = Workbooks.Open(path)
Set colRange = wb.Sheets(Dsheet).Range(wb.Sheets(Dsheet).Cells(4, 2), wb.Sheets(Dsheet).Cells(4, 56))
Set rowRange = wb.Sheets(Dsheet).Range(wb.Sheets(Dsheet).Cells(7, 1), wb.Sheets(Dsheet).Cells(27, 1))
For c = 2 To 57
For r = 8 To 73
Set rowCell = Application.Match(G2.Cells(r, 1), rowRange, 0)
Set colCell = Application.Match(G2.Cells(4, c), colRange, 0)
wb.Sheets(Dsheet).Range(rowCell, colCell).Copy
G2.Cells(r, c).PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next r
Next c
do some stuff with the comment
wb.Close SaveChanges:=False
Next i
Have you considered copying everything over at the same time?
So instead of this:
G2.Cells(r, c).Value = wb.Sheets(Dsheet).Range(rowCell, ColCell, colRange, 0)).copy
Maybe you could do this:
wb.Sheets(Dsheet).Range(rowCell, ColCell, colRange, 0)).copy
G2.Cells(r, c).PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
See this link for more information on the PasteSpecial method.
See this link for more information on the different paste types.