I'm trying to copy the data from one sheet to the last row of another sheet.
The reason why I am doing this is because I want to consolidate the data in a sheet which is already existing and my contain already a data.
Below is my code so far which only copies again to the A2 of another sheet. What approach should I do for this:
Sub Upload()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim MainPage As Worksheet
Set MainPage = Sheets("Main")
Dim r As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Wb1 = ActiveWorkbook
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a File", _
filefilter:="Excel File *.xlsx (*.xlsx),")
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set Wb2 = Workbooks.Open(Filename:=FileToOpen)
With Wb2.Sheets("ALL TICKETS (excpt Open-OnHold)")
srcLastRow = .Range("A:AJ").Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
destLastRow = Wb1.Sheets("ALL TICKETS (excpt Open-OnHold)".Range("A:AJ").Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row + 1
Wb1.Sheets("ALL TICKETS (excpt Open-OnHold)").Range("A2:AJ" &
destLastRow).Value = .Range("A2", "AJ" & srcLastRow).Value
End With
Wb2.Close
End If
End Sub
You know your copied range, so then you need to know the last row of the destination sheet:
dim lr as long
With Sheets("Destination")
lr = .cells(.rows.count,1).end(xlup).row 'assumes column 1 is contiguous
End with
You can then take your source range (will use variable SrcRng) and paste to the new sheet, into a specific cell:
SrcRng.Copy Sheets("Destination").Cells(lr+1,1) 'this line does the copy and the paste
The rest of the copied range will be filled in.
Edit1:
Hard to show the code in a comment...
Dim LRSrc as Long, LRDest as Long, SrcRng as Range
With Sheets("Source")
LRSrc = .cells(.rows.count,1).end(xlup).row 'assumes column 1 is contiguous
Set SrcRng = .Range("A1:AJ" & LRSrc)
End with
With Sheets("Destination")
LRDest = .cells(.rows.count,1).end(xlup).row 'assumes column 1 is contiguous
SrcRng.Copy .Cells(LRDest+1,1)
End with
Would this work for you.
defining srcLastRow as below.
srcLastRow = Cells(Rows.Count, 36).End(xlUp).Row
Related
I am a bit stuck and hoping to find some help. I have some experience in VBA but this particular problem exceeds my programming knowledge.
I have a sheet with 1000 - 1250 rows of data, and anywhere from 20 - 60 columns that can change monthly.
What I am hoping to do is look at each cell for an X, and when found it will create a new line on a separate tab. The line would contain the first cell in the row where the X was found and the column header from the column the X was found in.
I have been able to write some things that will find the X's in the sheet, create new items on another page and the like, but I can't get one script to do everything I need.
This is an example of the data structure:
Data
Expected result:
Output
Sorry for the links, I am too new to post photos.
Any help on how this can be achieved, documents, tips or the like would be super helpful and most appreciated. Thank you for looking!
Andrew
EDIT:
Some of the code I have put together:
Dim uSht As String
Dim wsExists As Boolean
Dim lRow As Long
Dim lcol As Long
Dim ws As Worksheet
Sub CopyData()
'Setup Sheetnames
uSht = "UPLOAD"
uTem = "TEMPLATE"
' Stop flicker
Application.ScreenUpdating = False
' Check for Upload Worksheet
WorksheetExists (uSht)
'MsgBox (wsExists)
If wsExists = False Then
' If it does not exist, create it
Call CreateSheet("UPLOAD")
End If
'Setup stuff
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets(uTem)
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(uSht)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox (lRow)
'MsgBox (lCol)
Range(Cells(lRow, lColumn)).Select
Application.ScreenUpdating = True
End Sub
Sub CreateSheet(wsName)
'Creates the uSht worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = uSht
End With
End Sub
Function WorksheetExists(wsName As String) As Boolean
'Check to see if uSht exists and return.
wsName = UCase(wsName)
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = wsName Then
wsExists = True
Exit For
End If
Next
WorksheetExists = wsExists
End Function
Using FindAll from here: Extracting specific cells from multiple Excel files and compile it into one Excel file
(but change LookAt:=xlPart to LookAt:=xlWhole)
Rough outline:
Dim col, c, dest As Range
Set dest = sheets("results").Range("A2")
Set col = FindAll(sheets("data").range("a1").currentregion, "X")
For each c in col
dest.resize(1,2).value = array(c.entirerow.cells(1).value, _
c.entirecolumn.cells(1).value)
set dest = dest.offset(1, 0)
next
You need a Find/FindNext loop that will locate all X values in the first worksheet. After a found cell is located, the cell's row and column can be used to identify the location and project.
Option Explicit
Sub Macro1()
Dim addr As String, loc As String, pro As String
Dim ws2 As Worksheet, fnd As Range
Set ws2 = Worksheets("sheet2")
With Worksheets("sheet1")
Set fnd = .Cells.Find(What:="x", after:=.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
addr = fnd.Address(0, 0)
Do
loc = .Cells(fnd.Row, "A").Value
pro = .Cells(1, fnd.Column).Value
With ws2
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = loc
.Cells(.Rows.Count, "A").End(xlUp).Offset(0, 1) = pro
End With
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address(0, 0)
End If
End With
End Sub
I am trying to compare two workbooks but unlikely upon Running the Macro, getting Error
"Subscript Out of the Range".
Can anyone please help in Removing the Error? Thanks
Sub CompInTwoWorkbooks()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range, rng As Range
Dim lnLastRow1 As Long, lnLastRow2 As Long
Dim lnTopRow1 As Long, lnTopRow2 As Long
Dim lnCols As Long, i As Long
Set wb1 = Workbooks("listeappli.xlsx") 'Adjust as required
Set wb2 = Workbooks("Keyword.xlsx") 'Adjust as required
Set ws1 = wb1.Sheets("listeappli") 'Adjust as required
Set ws2 = wb2.Sheets("Keyword") 'Adjust as required
lnTopRow1 = 2 'first row containing data in wb1 'Adjust as required
lnTopRow2 = 2 'first row containing data in wb2 'Adjust as required
'Find last cells containing data:
lnLastRow1 = ws1.Range("M:M").Find("*", Range("M1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
lnLastRow2 = ws2.Range("A:A").Find("*", Range("A1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
Set rng = ws2.Range("A" & lnTopRow2 & ":A" & lnLastRow2)
lnCols = ws1.Columns.Count
ws1.Columns(lnCols).Clear 'Using the very right-hand column of the sheet
For i = lnLastRow1 To lnTopRow1 Step -1
For Each c In rng
If ws1.Range("M" & i).Value = c.Value Then
ws1.Cells(i, lnCols).Value = "KEEP" 'Add tag to right-hand column of sheet if match found
Exit For
End If
Next c
Next i
'Delete rows where the right-hand column of the sheet is blank
Set rng = ws1.Range(Cells(lnTopRow1, lnCols), Cells(lnLastRow1, lnCols))
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ws1.Columns(lnCols).Clear
End Sub
If your workbook is not open already and you want the macro to open it automatically you must use the Workbooks.Open Method.
use the following if listeappli.xlsx is in the same path as the actual file
Set wb1 = Workbooks.Open(Filename:=ThisWorkbook.Path & Application.PathSeparator & "listeappli.xlsx")
or specify the full path for Filename:= like
Set wb1 = Workbooks.Open(Filename:="C:\MyFolder\listeappli.xlsx")
i have this code:
Sub reportCreation()
Dim sourceFile As Variant
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim sourceSheet As Worksheet
Dim destSheet As Worksheet
Dim rng As Range
Dim i As Long
Dim NValues As Long
If sourceFile = False Then
MsgBox ("Select the MyStats file that you want to import to this report")
sourceFile = Application.GetOpenFilename
Set wbSource = Workbooks.Open(sourceFile)
Set sourceSheet = wbSource.Sheets("Test Dummy Sheet")
Set rng = sourceSheet.Range("A:N")
rng.Copy
Set wbDest = ThisWorkbook
Set destSheet = wbDest.Sheets("MyStats")
destSheet.Range("A1").PasteSpecial
Application.CutCopyMode = False
wbSource.Close
End If
NValues = destSheet.Cells(destSheet.Rows.Count, 2).End(xlUp).Row
With destSheet
For i = 6 To NValues
' Cells(i, 3).NumberFormat = "0"
With Cells(i, 3)
.Value = Cells.Value / 1000000
.NumberFormat = "0.00"
End With
Next i
End With
End Sub
the code runs fine for the IF Statement part which is a simple cop and paste sort of scenario but then once the WS has been copied to the new WB i need column 3 to devide any cell in that is larger than 1M by 1M and as soon as the code finds the first cell with a value of over 1M i get an error message "Runtime Error 7, system out of memory" but i still have 2GB left of memory so this does not seem to be your tipycal out of mem issue where i need to close a few applications and it will run because it just does not.
i am wondering if there is an issue with my code?
some of the sample values that the code will look are:
16000000
220000
2048000
230000
16000000
230000
16000000
you may want to adopt a different approach like follows (see comments)
Option Explicit
Sub reportCreation()
Dim sourceFile As Variant
Dim sourceSheet As Worksheet
Dim tempCell As Range
sourceFile = Application.GetOpenFilename(Title:="Select the MyStats file that you want to import to this report", _
FileFilter:="Excel Files *.xls* (*.xls*),") '<-- force user to select only excel format files
If sourceFile = False Then Exit Sub '<-- exit if no file selected
Set sourceSheet = TryGetWorkSheet(CStr(sourceFile), "Test Dummy Sheet") '<-- try and get the wanted worksheet reference in the chosen workbook
If sourceSheet Is Nothing Then Exit Sub '<-- exit if selected file has no "Test Dummy Sheet" sheet
With sourceSheet '<-- reference your "source" worksheet
Intersect(.UsedRange, .Range("A:N")).Copy
End With
With ThisWorkbook.Sheets("MyStats") '<-- reference your "destination" worksheet
.Range("A1").PasteSpecial
Application.CutCopyMode = False
sourceSheet.Parent.Close
Set tempCell = .UsedRange.Cells(.UsedRange.Rows.Count + 1, .UsedRange.Columns.Count) '<-- get a "temporary" cell not in referenced worksheet usedrange
tempCell.Value = 1000000 'set its value to the wanted divider
tempCell.Copy ' get that value into clipboard
With .Range("C6:C" & .Cells(.Rows.Count, 2).End(xlUp).Row) '<-- reference cells in column "C" from row 6 down to last not empty one in column "B"
.PasteSpecial Paste:=xlValues, Operation:=xlPasteSpecialOperationDivide '<-- divide their values by clipboard content
.NumberFormat = "0.00" '<-- set their numberformat
End With
tempCell.ClearContents '<-- clear the temporary cell
End With
End Sub
Function TryGetWorkSheet(wbFullName As String, shtName As String) As Worksheet
On Error Resume Next
Set TryGetWorkSheet = Workbooks.Open(wbFullName).Sheets("Test Dummy Sheet")
End Function
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
I have a file that I would like to run a Find and Replace on using data from another Excel file.
I have this so far, what am I doing wrong?
Sub LegalName()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet
Set NameListWB = Workbooks.Open("File.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
Dim rng As Range
Set rng = NameListWS.Range("A:B").Select
Do Until IsEmpty(ActiveCell)
Worksheets("Sheet1").Columns("F").Replace _
What:=ActiveCell.Value, Replacement:=ActiveCell.Offset(0, 1).Value, _
SearchOrder:=xlByColumns, MatchCase:=False
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I see that you started by declaring your objects but missed out on few. Also, you need to avoid the use of .Select Interesting Read
Is this what you are trying (UNTESTED)?
Sub Sample()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'~~> This is the workbook from where your code is running
Set thisWb = ThisWorkbook
'~~> Change this to the sheet name where you want to replace
'~~> in Column F
Set thisWs = thisWb.Sheets("Sheet1")
'~~> File.xlsx
Set NameListWB = Workbooks.Open("C:\File.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'~~> Find last row in Col A of File.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop though Col A
For i = 1 To lRow
'~~> Do the replace
thisWs.Columns(6).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub