So I want to copy lets say Rows 5-15 from Columns B,E,G, from one worksheet to another.
So far I have tried it like this
Sheets("Table1").Select
Range("B5:B15,E5:E15,G5:G15").Select
Selection.Copy
Sheets("Table2").Select
Range("B4").Select
ActiveSheet.Paste
That's the concept.
I have much more Columns to copy and when doing it it doesn't work as I want like this
Sheets("Table1").Select
Range("CT5:CT15,CB5:CB15,CN5:CN15,DJ5:DJ15,DL5:DL15,E5:E15,AP5:AP15,CU5:CU15,AZ5:AZ15,AX5:AX15,CZ5:CZ15,CV5:CV15,AR5:AR15,AM5:AM15,Q5:Q15,CG5:CG15,AC5:AC15,R5:R15,CY5:CY15,G5:G15,Z5:Z15,C5:C15,DP5:DP15,Y5:Y15,X5:X15,CJ5:CJ15,DQ5:DQ15,CQ5:CQ15,AK5:AK15,AJ5:AJ15,BA5:BA15,BQ5:BQ15,CL5:CL15,BH5:BH15,DO5:DO15,AB5:AB15,CH5:CH15,CK5:CK15,P5:P15,CI5:CI15").Select
Selection.Copy
Sheets("Table2").Select
Range("B4").Select
ActiveSheet.Paste
Is there a way to streamline? To say I wand Row 5-15 from all these columns?
Thank you
You could use Intersect to get the range to copy.
Dim rngCopy As Range
Dim rngCols As Range
Dim rngRows As Range
With Sheets("Tabelle1")
Set rngCols = .Range("B:B, E:E, G:G")
Set rngRows = .Rows("5:15")
End With
Set rngCopy = Intersect(rngCols, rngRows)
rngCopy.Copy Sheets("Tabelle2").Range("A4")
Copy Non-Contiguous Columns Range
Adjust the values in the constants section.
Option Explicit
Sub copyMultiColumns()
' Source
Const sName As String = "Table1"
Const sRows As String = "5:15"
Const sColsList As String = "" _
& "C,E,G,P,Q,R,X,Y,Z," _
& "AB,AC,AJ,AK,AM,AP,AR,AX,AZ," _
& "BA,BH,BQ," _
& "CB,CG,CH,CI,CJ,CK,CL,CN,CQ,CT,CU,CV,CY,CZ," _
& "DJ,DL,DO,DP,DQ"
' Destination
Const dName As String = "Table2"
Const dFirst As String = "B4"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim srg As Range
Dim n As Long
For n = 0 To UBound(sCols)
If srg Is Nothing Then
Set srg = sws.Columns(sCols(n))
Else
Set srg = Union(srg, sws.Columns(sCols(n)))
End If
Next n
Set srg = Intersect(srg, sws.Rows(sRows))
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
srg.Copy dws.Range(dFirst)
End Sub
Related
Hello all I did a macro in VBA that should check column D for the first empty cell then paste on that row but on column C, and when adding new info in the table it should take the first empty cell again, but it is replacing data, I don't check column C for first row because I have an filled cell midway, and if data were to replace that cell it should add a new row and avoid that.
`Sub CopyPasteToAnotherSheet()
Dim sourceRange As Range
Dim targetRange As Range
Dim lastRow As Long
Dim firstEmptyRow As Long
Set sourceRange = Selection
Set targetRange = Sheets("PARKING").Range("D18")
lastRow = targetRange.End(xlDown).Row
firstEmptyRow = Sheets("PARKING").Range("D" & lastRow).End(xlUp).Row + 1
If lastRow = targetRange.Row Then
targetRange.EntireRow.Insert
End If
If Sheets("PARKING").Range("C" & firstEmptyRow).Value <> "" Then
firstEmptyRow = firstEmptyRow + 1
End If
Set targetRange = Sheets("PARKING").Range("C" & firstEmptyRow)
sourceRange.Copy
targetRange.PasteSpecial xlPasteValues
End Sub
`
I have tried to work with different search ranges but it keeps overwriting data.
also if it would keep numbering the newly added rows when adding new data it would be great I am clueless on how I should do that
Append Values
Sub AppendValues()
Const PROC_TITLE As String = "Append Values"
Const DST_NAME As String = "PARKING"
Const DST_FIRST_CELL As String = "C18"
If Selection Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf Selection Is Range Then Exit Sub ' not a range
Dim srg As Range: Set srg = Selection
Dim sws As Worksheet: Set sws = srg.Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
If Not sws.Parent Is wb Then Exit Sub ' not in this workbook
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
If sws Is dws Then Exit Sub ' src. and dst. are the same worksheet
If dws.FilterMode Then dws.ShowAllData ' '.Find' will fail if 'dws' filtered
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Dim dlCell As Range
Set dlCell = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If Not dlCell Is Nothing Then
Set dfCell = dfCell.Offset(dlCell.Row - dfCell.Row + 1)
End If
Dim sarg As Range
For Each sarg In srg.Areas
dfCell.Resize(sarg.Rows.Count, sarg.Columns.Count).Value = sarg.Value
Set dfCell = dfCell.Offset(sarg.Rows.Count)
Next sarg
MsgBox "Values appended to worksheet """ & DST_NAME & """.", _
vbInformation, PROC_TITLE
End Sub
I am trying to get data to be copy over to the next empty row. I have data starting in Cell A6. Can you please advise why my Lastrow2 is giving me an error and not copying the data to next empty row?
Dim FTO As Variant
Dim OB As Workbook
Dim Lastrow2 As Long
Lastrow2 = .Cells(.Rows.Count, "A").End(xlUp).Offset(-1).Row
Application.ScreenUpdating = False
FTO = Application.GetOpenFilename(Title:="Browse for your File & Import", FileFilter:="Excel Files (*.xls*), *xls*")
If FTO <> False Then
Set OB = Application.Workbooks.Open(FTO)
OB.Sheets(1).Range("E4:BW100").Copy
ThisWorkbook.Worksheets("Master").Range("A6" & Lastrow2).PasteSpecial xlPasteValues
OB.Close False
End If
Application.ScreenUpdating = True
I have tried modifying the lastrow function using the following code. Can I use the piece below to work on the function?
Lastrow2 = ThisWorkbook.Sheets(1).Range("A6").End(xlDown).Row + 1
Range(Selection, Selection.End(xlDown)).Select
If FTO <> False Then
Set OB = Application.Workbooks.Open(FTO)
OB.Sheets(1).Range("E4:BW100").Copy
ThisWorkbook.Worksheets("Master").Range("A6" & Lastrow2).PasteSpecial xlPasteValues
OB.Close False
End If
Application.ScreenUpdating = True
Copy Values From a Closed Workbook
The Issue
The expression LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Offset(-1).Row is wrong because of the -1 and could only work in a With statement:
Dim FirstRow As Long
With ThisWorkbook.Sheets("Master")
FirstRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
End With
or, if you need the first cell
Dim FirstCell As Range
With ThisWorkbook.Sheets("Master")
Set FirstCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
These leading dots tell us that these cells or rows are located in the worksheet Master in the workbook containing this code (ThisWorkbook).
An Improvement
Sub CopyValues()
' Define constants.
' The Source workbook will be opened using 'Application.GetOpenFilename'.
Const SRC_WORKSHEET_INDEX As Long = 1
Const SRC_RANGE As String = "E4:BW100"
' The Destination workbook is the workbook containing this code.
Const DST_WORKSHEET_NAME As String = "Master"
Const DST_COLUMN As String = "A"
Application.ScreenUpdating = False
' Open the Source file (or not).
Dim SourcePath: SourcePath = Application.GetOpenFilename( _
Title:="Browse for your File & Import", _
FileFilter:="Excel Files (*.xls*), *xls*")
If VarType(SourcePath) = vbBoolean Then Exit Sub ' i.e. 'False'
' Reference the Source range.
Dim swb As Workbook: Set swb = Workbooks.Open(SourcePath)
Dim sws As Worksheet: Set sws = swb.Worksheets(SRC_WORKSHEET_INDEX)
Dim srg As Range: Set srg = sws.Range(SRC_RANGE)
' Reference the Destination range.
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim dws As Worksheet: Set dws = dwb.Sheets(DST_WORKSHEET_NAME)
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, DST_COLUMN).End(xlUp).Offset(1)
Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
' Copy values.
drg.Value = srg.Value
' Close the Source file.
swb.Close False
Application.ScreenUpdating = True
End Sub
I have a spreadsheet with over 10000 rows. I need to search it using InputBox (UPC field, input is from a barcode scanner).
I need to copy the row of the found cell, and paste it to another sheet.
This process should loop until the user cancels the InputBox.
I have done this, but it gives me an error on the SelectCells.Select line, but not every time.
Sub Scan()
Do Until IsEmpty(ActiveCell)
Dim Barcode As Double
Barcode = InputBox("Scan Barcode")
Dim ws As Worksheet
Dim SelectCells As Range
Dim xcell As Object
Set ws = Worksheets("Sheet1")
For Each xcell In ws.UsedRange.Cells
If xcell.Value = Barcode Then
If SelectCells Is Nothing Then
Set SelectCells = Range(xcell.Address)
Else
Set SelectCells = Union(SelectCells, Range(xcell.Address))
End If
End If
Next
SelectCells.Select
Set SelectCells = Nothing
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Loop
End Sub
Copy Rows
Option Explicit
Sub Scan()
Const sName As String = "Sheet1"
Const Header As String = "Barcode"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim surg As Range: Set surg = sws.UsedRange
Dim slCell As Range
Set slCell = surg.Cells(surg.Rows.Count, surg.Columns.Count)
Dim shCell As Range
Set shCell = surg.Find(Header, slCell, xlFormulas, xlWhole, xlByRows)
If shCell Is Nothing Then
MsgBox "The cell containing the header '" & Header _
& "' was not found.", vbCritical
Exit Sub
End If
Dim sfCol As Long: sfCol = surg.Column
Dim srg As Range
Set srg = sws.Range(sws.Cells(shCell.Row + 1, sfCol), slCell)
Dim scColIndex As Long: scColIndex = shCell.Column - sfCol + 1
Dim scrg As Range: Set scrg = srg.Columns(scColIndex)
Dim SelectedRows As Range
Dim Barcode As Variant
Dim srIndex As Variant
Do
Barcode = InputBox("Scan Barcode")
If Len(CStr(Barcode)) = 0 Then Exit Do
If IsNumeric(Barcode) Then
srIndex = Application.Match(CDbl(Barcode), scrg, 0)
If IsNumeric(srIndex) Then
If SelectedRows Is Nothing Then
Set SelectedRows = srg.Rows(srIndex)
Else
Set SelectedRows = Union(SelectedRows, srg.Rows(srIndex))
End If
End If
End If
Loop
If SelectedRows Is Nothing Then
MsgBox "No scan results.", vbExclamation
Exit Sub
End If
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim durg As Range: Set durg = dws.UsedRange
Dim dlRow As Long: dlRow = durg.Row + durg.Rows.Count - 1
Dim dlCell As Range
If dlRow < dfCell.Row Then
Set dlCell = dfCell
Else
Set dlCell = dws.Cells(dlRow + 1, dfCell.Column)
End If
SelectedRows.Copy dlCell
MsgBox "Rows copied.", vbInformation
End Sub
You can try something like this:
Sub Scan()
Dim Barcode As String, rngData As Range, m, rngDest As Range
'Column with barcodes
With Worksheets("Sheet1")
Set rngData = .Range("D1", .Cells(Rows.Count, "D").End(xlUp))
End With
'First paste postion
Set rngDest = Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1)
Do
Barcode = InputBox("Scan Barcode")
If Len(Barcode) = 0 Then Exit Do
'm = Application.Match(Barcode, rngData, 0) 'Barcodes formatted as text
m = Application.Match(CDbl(Barcode), rngData, 0) 'Barcodes formatted as numbers
If Not IsError(m) Then
rngData.Rows(m).EntireRow.Copy rngDest 'copy to Sheet2
Set rngDest = rngDest.Offset(1)
Else
'if no match then what?
Debug.Print "no match"
End If
Loop
End Sub
Depending on how your barcodes are stored (as text, or a numeric values) you may need to use CDbl(Barcode) inside the call to Match()
I want to select particular columns and then paste this onto a particular sheet, if sheet exists then erase existing data and paste newly copied data. This should work in loop to be refreshed with new data entered in the main sheet.
My code creates the required sheet but pastes data into another new sheet.
Sub Datasort()
'The sheet with all the imported data columns must be active when this macro is run
Dim newSht As Worksheet, sSht As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, Sheet_Name As String
Set sSht = Worksheets("all zip codes")
'Expand the array below to include all relevant column headers
Hdrs = Array("Country", "Zip codes", "GSS")
Application.ScreenUpdating = False
Sheet_Name = "Dataformatted"
Set newSht = Worksheets.Add(after:=sSht)
With sSht.UsedRange.Rows(1)
For i = LBound(Hdrs) To UBound(Hdrs)
Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
If Not Fnd Is Nothing Then
Intersect(Fnd.EntireColumn, sSht.UsedRange).Copy
newSht.Cells(1, i + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
newSht.Cells(1, i + 1).PasteSpecial Paste:=xlPasteColumnWidths
End If
Next i
Application.CutCopyMode = False
End With
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets.Add(after:=sSht).Name = Sheet_Name
End If
Application.ScreenUpdating = True
End Sub
Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim newSht As Worksheet
Sheet_Exists = False
For Each newSht In ThisWorkbook.Worksheets
If newSht.Name = WorkSheet_Name Then
Sheet_Exists = True
End If
Next
End Function
(not tested), but you're adding sheet everytime it runs, so assuming everything else works fine, you should:
replace Set newSht = Worksheets.Add(after:=sSht) with below
if not Sheet_Exists(Sheet_Name) then Worksheets.Add(after:=sSht).Name = Sheet_Name
Set newSht = Worksheets(Sheet_Name)
and remove the following part
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets.Add(after:=sSht).Name = Sheet_Name
End If
Copy Worksheet Columns
Option Explicit
Sub Datasort()
Const sName As String = "all zip codes"
Const dName As String = "Dataformatted"
Const dfcAddress As String = "A1"
Dim Headers As Variant: Headers = VBA.Array("Country", "Zip codes", "GSS")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.UsedRange
Dim shrg As Range: Set shrg = srg.Rows(1)
Application.ScreenUpdating = False
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If dws Is Nothing Then
Set dws = wb.Worksheets.Add(After:=sws)
dws.Name = dName
Else
dws.UsedRange.Clear
End If
Dim dfCell As Range: Set dfCell = dws.Range(dfcAddress)
Dim scrg As Range
Dim hIndex As Variant
Dim c As Long
For c = 0 To UBound(Headers)
hIndex = Application.Match(Headers(c), shrg, 0)
If IsNumeric(hIndex) Then
Set scrg = srg.Columns(hIndex)
dfCell.Resize(scrg.Rows.Count).Value = scrg.Value
dfCell.EntireColumn.ColumnWidth = scrg.EntireColumn.ColumnWidth
Set dfCell = dfCell.Offset(, 1)
End If
Next c
Application.ScreenUpdating = True
MsgBox "Data formatted."
End Sub
The final code is this
Sub Unique_Values_Worksheet_Variables()
'1 Code + Sub splitByChars
Const Chars As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=dws.Range("A:A"), _
Unique:=True
dws.Columns("A:J").EntireColumn.AutoFit
Dim rng As Range:
Set rng = dws.Range("A1:B1", dws.Cells(dws.Rows.Count, 1).End(xlUp))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.HorizontalAlignment = xlCenter
Unfortunately this was just focused on one part which has to be copied, the values for these columns were in another column so i try to switch the code
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=dws.Range("A:A"), _
Unique:=True
to this. I used the macro reader for it.
Sub Test()
'
' Test Makro
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.ActiveSheet
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Application.ScreenUpdating = False
sws.Columns("C:C").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Columns("D:H").EntireColumn.Hidden = True
Columns("C:J").Select
Selection.Copy Destination:=dws.Range("A1")
End Sub
what works:
the code recognizes the part with the new worksheet dws.
it filters in sws the column C:C, what means
it also recognizes sws
what does not work:
by copy paste the range no values are hand over.
I have to use the advanced filter on C:C by avoiding duplicates, then i have data which i do not want to handover in column "D:I". The only thing what i want to hand over is column C & J. So i tried it with hiding the columns in between but it does not work.
Has anybody an idea?
i also tried it with .Delete what actually would be not that nice.
Is it a problem that i just assigned A1 for pasting it?
Selection.Copy Destination:=dws.Range("A1")
Copy Columns (Unique)
About Your Solution
Your solution is pretty cool. You probably meant to hide D:I though, which is a minor issue.
After hiding and filtering you might consider unhiding the columns and removing the filter to bring the source worksheet to the initial state.
I prefer using a worksheet with a name instead of ActiveSheet, but it's no big deal if you know what you're doing.
I don't like the references to the whole columns i.e. letting Excel (VBA) decide which range should be processed.
About the following
I first wrote the second code which is kind of more efficient but comes with the cost of not being able to control the order of the columns (due to Union) to be copied, hence the first code is recommended.
You can easily replace the source worksheet (Worksheets(sName)) with ActiveSheet if necessary.
It is assumed that the source data (table (one row of headers)) starts in cell A1. Otherwise, you may need to create the source range reference in a different way.
Adjust (play with) the values in the constants section.
Option Explicit
Sub copyColumnsUnique()
' Source
Const sName As String = "Sheet1"
Const sUniqueColumn As String = "C"
Const sCopyColumnsList As String = "C,J" ' exact order of the columns
' Destination (new worksheet)
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
Dim dCell As Range: Set dCell = wb.Worksheets _
.Add(After:=wb.Sheets(wb.Sheets.Count)).Range(dFirst)
Application.ScreenUpdating = False
Dim srg As Range
With wb.Worksheets(sName).Range("A1").CurrentRegion
.Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
Dim n As Long
For n = 0 To UBound(sCopyColumns)
.Columns(sCopyColumns(n)).Copy dCell
Set dCell = dCell.Offset(, 1)
Next n
.Parent.ShowAllData
End With
Application.ScreenUpdating = True
End Sub
Sub copyColumnsUniqueAsc()
' Source
Const sName As String = "Sheet1"
Const sUniqueColumn As String = "C"
Const sCopyColumnsList As String = "C,J" ' forced ascending order of columns
' Destination (new worksheet)
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
Application.ScreenUpdating = False
Dim srg As Range
With wb.Worksheets(sName).Range("A1").CurrentRegion
.Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
' Using 'Union' will force the resulting columns be in ascending order.
' If 'sCopyColumnsList' is "C,J,D", the order will be "C,D,J".
Dim n As Long
For n = 0 To UBound(sCopyColumns)
If srg Is Nothing Then
Set srg = .Columns(sCopyColumns(n))
Else
Set srg = Union(srg, .Columns(sCopyColumns(n)))
End If
Next n
End With
srg.Copy wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Range(dFirst)
srg.Parent.ShowAllData
Application.ScreenUpdating = True
End Sub
Thanks to #Tragmor
for everyone who has same kind of problems, this could solve it
Sub Test()
'
' Test Makro
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.ActiveSheet
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Application.ScreenUpdating = False
With sws
.Columns("C:C").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.Columns("D:H").EntireColumn.Hidden = True
.Columns("C:J").Copy Destination:=dws.Range("A1")
End With
End Sub