I'm trying to copy data from columns AJ through AQ from one workbook and paste the values in a new workbook. The number of rows is variable (dependent on the user). I've tried implementing the following code, but it only pastes the first row into the new workbook:
Dim i, j, LastRow, LastRow2
Set OldBook = ActiveWorkbook
Set NewBook = Workbooks.Add(xlWBATWorksheet)
With NewBook
.ActiveSheet.Name = "GMD"
End With
OldBook.Activate
Sheets("Entry Sheet").Select
LastRow = ActiveSheet.Range("AJ" & Rows.Count).End(xlUp).Row ''Finds the last row of the column with text
LastRow2 = ActiveSheet.Range("AQ" & Rows.Count).End(xlUp).Row ''Finds the last row of the column with text
For i = 1 To LastRow ''Sets the range of rows to be copied including header
Range(Cells(i, 36), Cells(i, 43)).Select ''Selects relevant columns
Selection.Copy
NewBook.Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues
OldBook.Activate
Sheets("Entry Sheet").Select
Next i
For j = 1 To LastRow ''Sets the range of Rows to be copied including header
Range(Cells(j, 43), Cells(j, 44)).Select ''Selects relevant columns
Selection.Copy
NewBook.Activate
Range("H1").Select
ActiveSheet.Paste
OldBook.Activate
Sheets("Entry Sheet").Select
Next j
Any observations on what I'm doing wrong?
The problem is that in you paste section you are only calling the first cell and it is in the loop so each time the loop will paste in cell A1.
Also if all you want is values, it is best to skip the clipboard and assign the values directly. With this you can avoid the loop all together.
Thirdly avoid using the select.
Edit: Removed loop and added the wrap text for the line breaks.
Dim i, LastRow
Dim ws As Worksheet
Set oldbook = ActiveWorkbook
Set ws = oldbook.Sheets("Entry Sheet")
Set newbook = Workbooks.Add(xlWBATWorksheet)
With newbook
.ActiveSheet.Name = "GMD"
End With
With ws
LastRow = .Range("AJ" & .Rows.Count).End(xlUp).Row ''Finds the last row of the column with text
newbook.Sheets("GMD").Range(newbook.Sheets("GMD").Cells(1, 1), newbook.Sheets("GMD").Cells(LastRow, 7)).Value = .Range(.Cells(1, 36), .Cells(LastRow, 43)).Value
End With
newbook.Sheets("GMD").Range("H:I").WrapText = True
Related
I'm working on a excel document with multiple seperate data, all in a single column (A1 to A10160).
All the data begins in a cell with the text NC/xx/xxxx/x (x being variable) and ending in a cell containing different dates but the cell above it always has the text "Start Date". Some data covers 49 cells others cover 51 cells so it's not contained in a fixed number of cells in the column.
I need to copy the range from NC/xx/xxxx/x to Start Date plus one for each data "set", transpose it and paste all the data in the column in a new sheet.
Really haven't found anything useful so far but I am fumbling with this one:
Sub Find()
Dim Search, End, Start, i As Integer, j As Integer, L
Search = Cells(1, 1)
End = Cells(2, 1)
For i = 1 To 10160
If Left(Cells(i, 1), 3) = Search Then
Start = i - 0
End If
Next i
For j = 1 To 10160
If Cells(j, 1) = End Then
L = j + 1
End If
Sheet4.Select
Range(Cells(Start, 1), Cells(L + 2, 1)).Select
Selection.Copy
Sheet4.Range("BB23").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End
Next j
End Sub
Would really appreciate any help I can get!
Thanks!
It looks like you haven't had much interest in your question, so I've taken a look at it. It's one of those fiddly jobs - not terribly technical but tricky to get the flow of logic right. The code below gives you what you've outlined in your question. You've said transpose it - so that's what the code does. Try it and let me know how you go.
Option Explicit
Sub Copy2Sheet2()
'Declare all your variables
Dim ws1 As Worksheet, ws2 As Worksheet
Dim topRow As Long, BottomRow As Long, LastRow As Long
Dim PasteToRow As Long, i As Long, c As Range
'Set the sheet variables
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
'Initial row settings
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 '<~~ assumes headers on sheet2
'Start the loop
For i = 1 To LastRow
'Find the bottom row of the first block of data
Set c = ws1.Range("A" & i & ":A" & LastRow).Find(What:="Start Date", LookIn:=xlValues)
BottomRow = c.Row + 1
'Define and copy the range to sheet2
ws1.Range("A" & i & ":A" & BottomRow).Copy
ws2.Range("A" & PasteToRow).PasteSpecial Transpose:=True
Application.CutCopyMode = False
'Redefine the 'paste to' row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Redefine the top row of the next block of data
i = BottomRow
'Repeat the process
Next i
End Sub
I'm having some issues with last row expression and autofill. I'm not sure what I'm missing here as it looks correct but it doesn't seem to be starting the vlookup in the proper cell (N2, it starts it in N1) and it won't autofill to the last row of M. Any push in the right direction would be greatly appreciated. I'm thinking it's something small I'm overlooking.
Sub Nightly()
'
' Nightly Macro
'
Dim PackSpec As Workbook
Dim FullBook As Workbook
Dim DebFile As Workbook
Dim lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
'Open the nightly pack spec file, cut and insert the year row into column D
Set PackSpec = Workbooks.Open("S:\Accounting\Apps\Packspec\CIDExport\Archive\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date) - 1 & "\*.csv")
Columns("A:A").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Range("A2").Select
'Open Fullbook master and insert columns after N then VLookup between Pack Spec and Fullbook
Set FullBook = Workbooks.Open("S:\Corporate\Groups\Comosoft\Downloads\FullBook\fullbook_Master.csv")
Columns("N:U").Select
Selection.Insert Shift:=xlToRight
Range("N2").Select
'Actvate Fullbook and enter Vlookup for dates
Windows("fullbook_Master.csv").Activate
With ActiveSheet.Range("N2")
.FormulaR1C1 = "=VLOOKUP(RC[-1],'[15.50.1.CID.csv]15.50.1.CID'!C[-13]:C[-11],3,0)"
.AutoFill Destination:=Range("N2:N" & lrow) 'issue not autofilling to end
Windows("fullBook_Master.csv").Activate
End With
End Sub
Just move the
lrow = Cells(Rows.Count, 1).End(xlUp).Row
after
Windows("fullbook_Master.csv").Activate
You should:
Link lrow to a sheet to avoid mistakes.
Avoid all the selects.
Sub Nightly()
'
' Nightly Macro
'
Dim PackSpec As Workbook
Dim FullBook As Workbook
Dim DebFile As Workbook
Dim lrow As Long
Dim ws As Worksheet, wsPackSpec As Worksheet
Set ws = Activesheet
'Or set ws = Sheets("Sheet1") - better
'Open the nightly pack spec file, cut and insert the year row into column D
Set PackSpec = Workbooks.Open("S:\Accounting\Apps\Packspec\CIDExport\Archive\" &
Year(Date) & "\" & Month(Date) & "\" & Day(Date) - 1 & "\*.csv")
Set wsPackSpec = PackSpec.Sheets(1)
wsPackSpec.Columns(1).Value = wsPackSpec.Columns(4).Value
wsPackSpec.Columns(1).EntireColumn.Delete
'Open Fullbook master and insert columns after N then VLookup between Pack Spec and Fullbook
'Apply same principle as above here
Set FullBook = Workbooks.Open("S:\Corporate\Groups\Comosoft\Downloads\FullBook\fullbook_Master.csv")
Columns("N:U").Select
Selection.Insert Shift:=xlToRight
Range("N2").Select
'Actvate Fullbook and enter Vlookup for dates
Windows("fullbook_Master.csv").Activate
Set ws = ActiveSheet 'Set like this, but you should designate the correct worksheet in the fullbook part above
lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With ws
.Cells(2, 14).FormulaR1C1 = "=VLOOKUP(RC[-1],'[15.50.1.CID.csv]15.50.1.CID'!C[-13]:C[-11],3,0)"
.Cells(2, 14).AutoFill Destination:=.Range(.Cells(2, 14), .Cells(lrow, 14))
End With
End Sub
Something like this, couldn't test in detail because I'm missing the overview of how the books are set up.
I have written some code that, when there is a Duplicate value in Column A, then True = False would be there, same as we do in Excel, A1=A2, until the last row where we have data in A.
I am unsure how to find the last row , so i have coded the range up to T9000, but there could be data up to T3500, or sometimes T15000.
Range("A1:A5000").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
ActiveCell.FormulaR1C1 = "Dup"
Range("T2").Select
ActiveCell.FormulaR1C1 = "=R[-1]C[-19]=RC[-19]"
Range("T3").Select
Selection.End(xlDown).Select
Range("S1048576").Select
Selection.End(xlUp).Select
Range("T9000").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
I am unsure about the placement of your Dup should it be cell A1? The rest of your code can be contracted by using your last row variable.
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
Contracted code:
Option Explicit
Sub FindDups()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook 'Variable assignments
Set wsSource = wb.Worksheets("Sheet2")
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row 'find last row by coming from the bottom of the sheet and finding last used cell in column
With wsSource
.Range("A1").FormulaR1C1 = "Dup"
.Range("A1:A" & lastRow).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
.Range("T2:T" & lastRow).FormulaR1C1 = "=IF(RC[-19]=R[-1]C[-19],""Duplicate"", RC[-19])"
End With
End Sub
Apologies editing .I have this below code which copies data of one row from 1 sheet to another (there are blanks in between). The code works fine, however I would like it copy only visible fields from sheet 1 (filters already applied).
This is copying the entire column U irrespective of the filters applied (filters are applied I column 10 and 38)
With Worksheets("Sheet1")
Set SrcRng = .Range(.Cells(1, "U"), .Cells(.Rows.Count, "U").End(xlUp))
End With
Worksheets("Sheet2").range("I1").Resize(SrcRng.Rows.Count, 1).Value = SrcRng.Value'
Please help
Try:
Sub CopyVisible()
Dim ws As Worksheet, ws2 As Worksheet
Dim SrcRange As Range, CpyRng As Range
Dim LRow As Long
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
If ws.AutoFilterMode Then ws.AutoFilter.ShowAllData 'Removes Previous Filters
With ws
LRow = .Cells(.Rows.Count, 8).End(xlUp).Row 'Check Col "H" for last data
Set SrcRng = .Range(.Cells(1, 1), .Cells(LRow, 39)) 'Range with Data
With SrcRng
.AutoFilter Field:=39, Criteria1:="Blue"
.AutoFilter Field:=8, Criteria1:="Pass"
.AutoFilter Field:=10, Criteria1:="<>"
End With
For i = 1 To LRow 'Loop through all Rows
If Not .Cells(i, 1).EntireRow.Hidden Then 'Checks if Row is Hidden
If CpyRng Is Nothing Then
Set CpyRng = .Range("U" & i)
Else
Set CpyRng = Union(CpyRng, .Range("U" & i))
End If
End If
Next i
End With
ws.AutoFilter.ShowAllData 'Remove Filters
CpyRng.Copy ws2.Range("I1") 'Copy and Paste
End Sub
Will apply filters to all Columns from 1 to 39 and filter with the wanted criteria. Creates range with all visible rows in Col U and paste them into Sheet2 into Col I.
I am currently using the following code to copy paste data from File- "Source" to File-"Destination". It is selecting the rows till data ends in Column-1.
However, currently all the columns from A to AE are selected, but instead I want selective columns like A,F,K,AA to be selected.
I understand that the code in "wb.ActiveSheet.Range("A2:AE" & N).Copy" needs to be changed but not sure of the syntax.
Can anyone help me with this? Appreciate the help in advance.
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim N As Long
Dim LastRow As Long
N = Cells(2, 1).End(xlDown).Row
wb.ActiveSheet.Range("A2:AE" & N).Copy
Set y = Workbooks.Open("C:\Desktop\Destination.xlsx")
y.Activate
y.Sheets("Data").Select
y.Sheets("Data").Activate
For Each Cell In y.Sheets("Data").Columns(1).Cells
If Len(Cell) = 0 Then Cell.Select: Exit For
Next Cell
Selection.PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = False
ActiveWorkbook.Close True
Application.DisplayAlerts = True
Application.CutCopyMode = False
You can use the Application.Union to combine ranges from different columns (from row 2 until N).
Also, instead of looping through your y.Sheets("Data").Columns(1).Cells to find the empty Cell, you can just use LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1.
I added 2 With wb.Sheets("Sheet1") to fully qualify all variables and Range nested underneath.
Code
Option Explicit
Sub CopyColumns()
Dim wb As Workbook
Dim Y As Workbook
Dim N As Long
Dim LastRow As Long
Dim CopyRng As range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
' you need to specify the sheet, otherwise it will take the Active Sheet
With wb.Sheets("Sheet1") ' <-- modify to your sheet's name
N = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- get last row from Column "A", skips blank cells in te middle
' set the range to Columns A, F, K, AA
Set CopyRng = Application.Union(.Range("A2:A" & N), .Range("F2:F" & N), .Range("K2:K" & N), .Range("AA2:AA" & N))
End With
Set Y = Workbooks.Open("C:\Desktop\Destination.xlsx")
With Y.Sheets("Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 '<-- get first empty row at Column A to paste at
CopyRng.Copy
.Range("A" & LastRow).PasteSpecial xlPasteValues
End With
Y.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub