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
Related
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()
The excel file I have is more than 1,000,000 rows and 26 columns.
Below is the code which is used to find a particular data and a new file is created on the basis of that data and currently it is taking around 15 mins to create a new file
Please if any expert can help me in processing the below macro faster.
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
strColumnValue = "1021 VDDGC 104"
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'Create a new Excel workbook
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.Rows(1).EntireRow.Copy
objSheet.Activate
objSheet.Range("A1").Select
objSheet.Paste
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range("K" & nRow).Value) = CStr(varColumnValue) Then
'Copy data with the same column "B" value to new workbook
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).Select
objSheet.Paste
objSheet.Columns("A:S").AutoFit
End If
Next
Next
End Sub
Copy Worksheet to a New Workbook
Copies (exports) the worksheet to a new workbook.
Sorts by and filters the criteria column.
Deletes the filtered rows.
Sub SplitWorksheetData()
Dim dt As Double: dt = Timer
Const Criteria As String = "1021 VDDGC 104"
Const CriteriaColumnIndex As Long = 2
Dim sws As Worksheet: Set sws = ActiveSheet ' improve!
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
If Not dict.Exists(Criteria) Then dict.Add Criteria, 1
Application.ScreenUpdating = False
Dim dwb As Workbook
Dim dws As Worksheet
Dim Key As Variant
For Each Key In dict.Keys
sws.Copy
Set dwb = Workbooks(Workbooks.Count)
Set dws = dwb.Worksheets(1)
If dws.FilterMode Then dws.ShowAllData
Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion
Dim ddrg As Range: Set ddrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
drg.Sort drg.Columns(CriteriaColumnIndex), xlAscending, , , , , , xlYes
drg.AutoFilter CriteriaColumnIndex, "<>" & Criteria
Dim vrg As Range
On Error Resume Next
Set vrg = ddrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
dws.AutoFilterMode = False
If Not vrg Is Nothing Then vrg.Delete
' Save code goes here...
'dwb.SaveAs...
Next Key
Application.ScreenUpdating = True
Debug.Print Timer - dt
MsgBox "Workbook created.", vbInformation
End Sub
I want to copy a range between sheets using for..next, I have working loop, I don't know how to define a range that will change for each x in my loop, the range should be cells to the right of x in columns B and C.
Sub macro_cpt()
Dim Wiazka As String
Application.ScreenUpdating = False
Set w = Sheets("data_test")
w.Select
ActiveSheet.AutoFilterMode = False
owx = Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To owx Step 3
Wiazka = Cells(x, "A")
If Not SheetExists(ActiveWorkbook, Wiazka) Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = Wiazka
Else
Sheets(Wiazka).Cells.ClearContents
End If
w.Select
????? Range ?????.Copy Sheets(Wiazka).Range("A1")
Next
Set W = Nothing
i = MsgBox("done.", vbInformation)
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
ActiveWorkbook.Close SaveChanges:=False
End Sub
Function SheetExists(Wb As Workbook, ShName As String) As Boolean
For Each s In Wb.Sheets
If s.Name = ShName Then
SheetExists = True
Exit Function
End If
Next
End Function
Copy to All Worksheets Except the First
In a worksheet (source) of the workbook containing this code (ThisWorkbook), in column A starting from the second row (A2), it will loop through each 3rd cell (containing a destination worksheet name) and copy the values from columns B:C in the current row, to cell A1 of each destination worksheet.
Option Explicit
Sub macro_cpt()
' Source
Const sName As String = "data_test"
Const sFirstRow As Long = 2
Const sCol As String = "A" ' column of the destination worksheet names
Const sStep As Long = 3 ' rows 2, 5, 8...
Const sCols As String = "B:C" ' columns of data to be copied
' Destination
Const dAddress As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Or:
'Dim wb As Workbook: Set wb = ActiveWorkbook ' workbook you're looking at
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sLastRow As Long
sLastRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
Dim scrg As Range: Set scrg = sws.Columns(sCols) ' Source Column Range
' The source and destination row ranges have the same number of columns.
Dim cCount As Long: cCount = scrg.Columns.Count
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
Dim srrg As Range ' Source Row Range
Dim dws As Worksheet
Dim drrg As Range ' Destination Row Range
Dim dName As String
Dim r As Long
For r = sFirstRow To sLastRow Step sStep
dName = sws.Cells(r, sCol)
' You don't want to (accidentally) write to the source worksheet.
If StrComp(dName, sName, vbTextCompare) <> 0 Then
If IsSheetNameTaken(wb, dName) Then ' all sheets, charts included
Set dws = wb.Worksheets(dName) ' error if chart
dws.Cells.ClearContents
Else ' worksheet doesn't exist
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
End If
Set srrg = scrg.Rows(r)
Set drrg = dws.Range(dAddress).Resize(, cCount)
' Copy values only (most efficiently)
drrg.Value = srrg.Value
' Copy values, formulas and formats.
'srrg.Copy drrg
'Else ' it's the source worksheet
End If
Next r
sws.Activate
'wb.Save ' uncomment after testing
Application.ScreenUpdating = True
MsgBox "Data distributed among worksheeets.", _
vbInformation, "Distribute Data"
'wb.Close ' uncomment after testing
End Sub
Function IsSheetNameTaken( _
ByVal wb As Workbook, _
ByVal SheetName As String) _
As Boolean
On Error Resume Next
Dim sh As Object: Set sh = wb.Worksheets(SheetName)
On Error GoTo 0
IsSheetNameTaken = Not sh Is Nothing
End Function
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