I want to copy from one sheet into another. The macro should recognize the worksheet via name:
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
Dim NewEnd As Long
Dim NewEnd2 As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("CALC").Select
Worksheets("CALC").Range("B5:J25000").ClearContents
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "15B2" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
With Wb1.Sheets("Data")
Set rngToCopy = .Range("F7, H7, N7", .Cells(.rows.Count, "F").End(xlUp))
End With
wb2.Sheets("CALC").Range("B5:D5").Resize(rngToCopy.rows.Count).Value = rngToCopy.Value
End If
This line gives me an error:
Set rngToCopy = .Range("F7, H7, N7", .Cells(.Rows.Count, "F").End(xlUp))
How can I copy mutiple columns in this case?
You can use Union to merge multiple columns to 1 Range.
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row ' get last row with data from column "F"
Set rngToCopy = Application.Union(.Range("F7:F" & LastRow), .Range("H7:H" & LastRow), .Range("N7:N" & LastRow))
rngToCopy.Copy
wb2.Sheets("CALC").Range("B5").PasteSpecial xlPasteValues
Related
Trying to loop though the worksheets to apply the filter on date, and copy all the filtered data into a "Report" sheet.
Here is code, which loops only the first sheet ( USD) and not the second one (EUR).
Sub SheetLoop()
Dim Ws As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim Rng As Range
Dim CRng As Range
Dim DRng As Range
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.Name <> DestSh.Name Then
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
End If
Next Ws
End Sub
Since AdvancedFilter needs the filtered range headers, you cannot copy only part of the filtered range, but you can delete the first row of the copied range, except the first copied range (from first sheet):
Sub SheetLoop()
Dim Ws As Worksheet, wb As Workbook, DestSh As Worksheet
Dim Rng As Range, CRng As Range, DRng As Range, i As Long
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.name <> DestSh.name Then
i = i + 1
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
If i > 1 Then DRng.cells(1).EntireRow.Delete xlUp 'delete the first row of the copied range, except the first case
Set DRng = DestSh.Range("A" & DestSh.rows.count).End(xlUp).Offset(1) 'reset the range where copying to
End If
Next Ws
MsgBox "Ready..."
End Sub
I need help one last time, code below works fine; it copies values (A1) from sheets that is in array to a new created sheet in org file. The last modyfication I want to make here, is that in this NOT_ORG file I want to copy range of values, rather than 1 value. This range always starts from A7, but the number of cols and rows might change. I want to copy this range dynamically and paste in in range(a1) in newly created sheet. I know that I should calculate lastRow & lastCol, but not sure where to put this code, and how to modify this last copy line to achieve this result.
Tagging #faneduru as he helped me initially.
Sub Test1()
Dim lastRow As Long
Dim WshtNames As Variant
Dim WshtNameCrnt As Variant
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open("C:\NOT_ORG.xlsx")
WshtNames = Array("2", "3")
For Each WshtNameCrnt In WshtNames
WB1.Sheets.Add.Name = WshtNameCrnt & "_new"
WB2.Worksheets(WshtNameCrnt).Range("A1").Copy ActiveSheet.Range("A1")
Next WshtNameCrnt
End Sub
Thanks in advance.
eM
Please, test the next code:
Sub Test1()
Dim lastRow As Long, lastCol As Long, WshtNames, WshtNameCrnt
Dim WB1 As Workbook, WB2 As Workbook, ws As Worksheet
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open("C:\NOT_ORG.xlsx")
WshtNames = Array("2", "3")
For Each WshtNameCrnt In WshtNames
WB1.Sheets.Add.Name = WshtNameCrnt & "_new"
Set ws = WB2.Worksheets(WshtNameCrnt)
lastRow = ws.Range("A" & ws.rows.count).End(xlUp).row
lastCol = ws.cells(7, ws.Columns.count).End(xlToLeft).Column
ws.Range(ws.Range("A" & 7), ws.cells(lastRow, lastCol)).Copy ActiveSheet.Range("A1")
Next WshtNameCrnt
End Sub
And a faster version, using an array:
Sub Test1Array()
Dim lastRow As Long, lastCol As Long, WshtNames, WshtNameCrnt
Dim WB1 As Workbook, WB2 As Workbook, ws As Worksheet, arr
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open("C:\NOT_ORG.xlsx")
WshtNames = Array("2", "3")
For Each WshtNameCrnt In WshtNames
WB1.Sheets.Add.Name = WshtNameCrnt & "_new"
Set ws = WB2.Worksheets(WshtNameCrnt)
lastRow = ws.Range("A" & ws.rows.count).End(xlUp).row
lastCol = ws.cells(7, ws.Columns.count).End(xlToLeft).Column
arr = ws.Range(ws.Range("A" & 7), ws.cells(lastRow, lastCol)).value
ActiveSheet.Range("A1").Resize(UBound(arr), UBound(arr, 2)).value = arr
Next WshtNameCrnt
End Sub
I have two worksheets in the same workbook where they have different # of columns containing policy information and I would like to use vba to save multiple workbooks based on a certain column (state) since trying to save 50 times manually isn't the most efficient way.
State in sheet1 is column E & in sheet2 is column F. Now sheet1 & sheet2 have different ranges & columns so last row may need to be defined separately.
I found some codes online but wasn't able to make it work. My issues now is how to incorporate sheet2 and secondly make it work. The codes I have now have script out of range error in line Windows(state).Activate
Sub ExtractToNewWorkbook()
Dim ws As Worksheet
Dim wsNew As Workbook
Dim rData As Range
Dim rfl As Range
Dim state As String
Dim sfilename As String
Dim LR1 As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
LR1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
'Apply advance filter in your sheet
With ws
Set rData = Range("A1", "E" & LR1)
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state = rfl.Text
Set wsNew = Workbooks.Add
sfilename = state & ".xlsx"
'Set the Location
ActiveWorkbook.SaveAs FilePath & sfilename
Application.DisplayAlerts = False
ws.Activate
rData.AutoFilter Field:=5, Criteria1:=state
rData.Copy
Windows(state).Activate
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next rfl
Application.DisplayAlerts = True
End With
ws.Columns(Columns.Count).ClearContents
rData.AutoFilter
End Sub
You should avoid ActiveWorkbook and .Activate (also see: How to avoid using Select in Excel VBA). Instead access the workbook wsNew directly:
Set wsNew = Workbooks.Add
sfilename = state & ".xlsx"
'Set the Location
wsNew.SaveAs FilePath & sfilename
Application.DisplayAlerts = False
rData.AutoFilter Field:=5, Criteria1:=state
rData.Copy
wsNew.Worksheets(1).Paste
wsNew.Close SaveChanges:=True
Note that in Set rData = Range("A1", "E" & LR1) you missed a . before the range to make it use the with statement: Set rData = .Range("A1", "E" & LR1)
Note that you should consider to rename wsNew into wbNew in your entire procedure because you set a workbook with Set wsNew = Workbooks.Add and not a worksheet.
I need to copy values of one excel and create a new one with required format. Say i need to copy columns from B11 to BG11 and rows will be till the end.( i don't know how to find the end of rows). And I have column heading in b7 to bg7. In between there are unwanted rows and i don't need it. So in the new excel i want column headings(which is from b7 to bg7) as first row and the values from b11 to bg11 till the end.
This is my first excel Macro. I don't know how to proceed. So with references from some stackoverflow question and other site, i have tried the below code. but it is not giving the required output.
Sub newFormat()
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“B” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Sheets("MySheetName").Range("B7:BG7").Copy
Sheets("MySheetName").Range("B11:BG11").Copy
Workbooks.Open Filename:=”C:\Users\abcd\Documents\Newformat.xlsx”
Worksheets(“Sheet1”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
this may be simple. any help would be appreciated.
Few things...
Do not use Integer for rows. Post xl2007, the number of rows have increased and Integer can't hold that. Use Long
You do not need to select a range to paste on it. You can directly perform the action.
You do not need to use a loop. You can copy ranges in two chunks
Work with objects so Excel doesn't get confused by your objects.
Since Sheet1 is empty, you don't need to find the last row there. Simply start at 1.
To output the data to new workbook, you have to use Workbooks.Add
See this example (Untested)
Sub newFormat()
Dim wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim LastRow As Long, erow As Long
'~~> Set this to the relevant worksheet
Set wsI = ThisWorkbook.Sheets("HW SI Upload")
'~~> Find the last row in Col B
LastRow = wsI.Range("B" & wsI.Rows.Count).End(xlUp).Row
'~~> Open a new workbook
Set wbO = Workbooks.Add
'~~> Set this to the relevant worksheet
Set wsO = wbO.Sheets(1)
'~~> The first row in Col A for writing
erow = 1
'~~> Copy Header
wsI.Range("B7:BG7").Copy wsO.Range("A" & erow)
'~~> Increment output row by 1
erow = erow + 1
'~~> Copy all rows from 11 to last row
wsI.Range("B11:BG" & LastRow).Copy wsO.Range("A" & erow)
'~~> Clear Clipboard
Application.CutCopyMode = False
'
'~~> Code here to do a Save As
'
End Sub
Different but the same
Rename the sheet
Sub Button1_Click()
Dim wb As Workbook, ws As Worksheet, sh As Worksheet
Dim LstRw As Long, Rng As Range, Hrng As Range
Set sh = Sheets("MySheetName")
With sh
Set Hrng = .Range("B7:BG7")
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
Set Rng = .Range("B11:BG" & LstRw)
End With
Application.ScreenUpdating = 0
Workbooks.Open Filename:="C:\Users\abcd\Documents\Newformat.xlsx"
Set wb = Workbooks("Newformat.xlsx")
Set ws = wb.Sheets(1)
Hrng.Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Rng.Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
ws.Name = sh.Name 'renames sheet
wb.Save
wb.Close
End Sub
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws