i have an error in the loop FOR. I don't understand why.My purpose is to activate the option "automatic calculation" then delete all old rows and finally add new ones.
Sub refresh()
'
' refresh Macro
'
' Touche de raccourci du clavier: Ctrl+y
'
Dim LastRow As Integer, i As Integer
Application.Calculation = xlAutomatic
Range("A6:AP1000").Select
Application.DisplayAlerts = False
Selection.Delete
Application.DisplayAlerts = True
Range("A6:AP1000").Select
Selection.ClearContents
Sheets("PTR").Range(“A” & Rows.Count).Select
For i = 2 To Sheets("PTR").Range(“A” & Rows.Count).End(xlUp).Row
If Cells(i, 1) = "X" Then
Range(Cells(i, 1), Cells(i, 20)).Select
Selection.Copy
Sheets("Analyse de risque").Range("B" & Rows.Count).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End If
Next i
End Sub
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim i As Integer
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Worksheets("PTR")
LastRow1 = WS1.Cells(1048576, 1).End(xlUp).Row ' COLUMN 1 ?????????
Set WS2 = Worksheets("Analyse de risque")
LastRow2 = WS2.Cells(1048576, 1).End(xlUp).Row ' COLUMN 1 ?????
For i = 2 To LastRow1
If Cells(i, 1) = "X" Then
Range(Cells(i, 1), Cells(i, 20)).Copy
WS2.Cells(LastRow2, 1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
LastRow2 = LastRow2 + 1
End If
Next i
Related
I have code that will loop through my worksheet, but it performs copies all of the rows and not just the ones based on my criteria. How would I get it to only copy the row I want?
Sub Major2_Paster()
Dim LastRow As Integer
Dim i As Integer
Dim erow As Integer
LastRow = Cells(Rows.count, 1).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 12) = “MLA” Then
range(Cells(i, 1), Cells(i, 21)).Select
Selection.Copy
Workbooks.Open Filename:="H:\Degrees List\Sorted_Workbooks\MLA Mar-17.xlsx"
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
A couple of things:
Only open the workbook once, this will be the most significant performance boost
Create references to workbooks/worksheets rather than using ActiveSheet/ActiveWorkbook
Indenting is so important. It makes code so much more readable and it's the first step in finding your own errors
Sub Major2_Paster()
Dim LastRow As Integer, i As Integer, erow As Integer
Dim destinationWorkbook As Workbook
Dim sourceWorksheet As Worksheet, destinationWorksheet As Worksheet
Set destinationWorkbook = Workbooks.Open(Filename:="H:\Degrees List\Sorted_Workbooks\MLA Mar-17.xlsx")
Set sourceWorksheet = ThisWorkbook.Worksheets("SheetName")
Set destinationWorksheet = destinationWorkbook.Worksheets("SheetName")
With sourceWorksheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 2 To LastRow
If sourceWorksheet.Cells(i, 12).Value = “MLA” Then
With destinationWorksheet
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
destinationWorksheet.Cells(erow, 1).Resize(1, 21).Value = sourceWorksheet.Range(sourceWorksheet.Cells(i, 1), sourceWorksheet.Cells(i, 21)).Value
End If
Next i
destinationWorkbook.Close SaveChanges:=True
Application.CutCopyMode = False
End Sub
I am using Excel 2007. I try to copy Unit-price from the Excel file-2 data to the Excel file-1 when certain columns data matching from file-1 with file-2.
Thanks for the helps & guidance.
My VBA Code:
Sub mySales()
Dim LastRow As Integer, i As Integer, erow As Integer, Pipe_Class As String, Pipe_Description As String, End_Type As String, Pipe_Size As String
Dim wbk As Workbook
strPriceFile = "C:\Temp\File-2.xlsx"
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Pipe_Class = ""
Pipe_Description = ""
End_Type = ""
Pipe_Size = ""
Pipe_Class = ActiveSheet.Cells(i, 1).Value
Pipe_Description = ActiveSheet.Cells(i, 2).Value
End_Type = ActiveSheet.Cells(i, 3).Value
Pipe_Size = ActiveSheet.Cells(i, 4).Value
Set wbk = Workbooks.Open(strPriceFile)
Worksheets("SOR2").Select
If Cells(i, 1) = Pipe_Class And Cells(i, 2) = Pipe_Description And Cells(i, 3) = End_Type And Cells(i, 4) = Pipe_Size Then
Range(Cells(i, 12), Cells(i, 12)).Select
Selection.Copy
??? After Here how select my current file & paste ????????
Worksheets("SOR1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 12).Select
ActiveSheet.Paste
ActiveWorkbook.Save
End If
Next i
ActiveWorkbook.Close
Application.CutCopyMode = False
End Sub
I haven't checked all your code, but I have refactored what you have in your question in an attempt to open the Workbook once and to assign proper objects so that you can keep track of what action is being applied to which worksheet.
Sub mySales()
Dim LastRow As Integer, i As Integer, erow As Integer
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim strPriceFile As String
Set wbDst = ActiveWorkbook
Set wsDst = ActiveSheet
strPriceFile = "C:\Temp\File-2.xlsx"
Set wbSrc = Workbooks.Open(strPriceFile)
Set wsSrc = wbSrc.Worksheets("SOR2")
LastRow = wsDst.Range("A" & wsDst.Rows.Count).End(xlUp).Row
erow = LastRow + 1
For i = 2 To LastRow
If wsSrc.Cells(i, 1).Value = wsDst.Cells(i, 1).Value And _
wsSrc.Cells(i, 2).Value = wsDst.Cells(i, 2).Value And _
wsSrc.Cells(i, 3).Value = wsDst.Cells(i, 3).Value And _
wsSrc.Cells(i, 4).Value = wsDst.Cells(i, 4).Value Then
wsSrc.Cells(i, 12).Copy wsDst.Cells(erow, 12)
erow = erow + 1 ' your current code would always copies to the same row,
' but I **think** you probably want to copy to the
' next row each time
End If
Next i
wbSrc.Close
If erow > LastRow + 1 Then
wbDst.Save
End If
wbDst.Close
End Sub
The code is completely untested but, even if it doesn't work, at least it should give you an idea of how you should be processing multiple workbooks and multiple worksheets.
I have a spreadsheet with 800k rows and 150 columns. I'm attempting to create new worksheets based on the contents of a column. So, for example if column Y has many elements ("alpha", "beta", "gamma", etc.) then I'd like to create new worksheets named "alpha", "beta", "gamma" which contain only the rows from the original that have those respective letters. I've found two scripts that work for smaller spreadsheets, but due to the size of this particular spreadsheet, they don't work.
Here are the two scripts that I have tried:
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
this returns "overflow"
the other code that I have tried:
Sub columntosheets()
Const sname As String = "VOTERFILE_WITHABSENTEEINFORMATI" 'change to whatever starting sheet
Const s As String = "O" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub
Returns error with "excel does not have enough resources".
Is it possible to do what I want on my hardware?
You can refer to the modified subroutine in another article 'Macro for copying and pasting data to another worksheet'.
Sub CopySheet()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
' column G has the criteria eg project ref
wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit
wsAll.Copy Before:=Sheets("All")
ActiveSheet.Name = wsCrit.Range("A2")
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wsCrit.Range("A1:A2"), _
Unique:=False
wsCrit.Rows(2).Delete
Next I
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
End Sub
I've created excel vba file. However, it takes very long time to run the whole file because the total of the rows is up to 270,000 lines. Does anyone know how can I speed up the running process? Any help would be much appreciated. Thanks in advance.
Sub datemodifiedFile()
Dim File1 As Object
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set File1 = fso.getfile("C:\Users\Meg\Desktop\Master File.xlsx")
If Sheets("today").Range("B1").Value = File1.DateLastModified Then
Else
Sheets("today").Range("B1").Value = File1.DateLastModified
Dim WbB As Workbook
Set WbB = Workbooks.Open(Filename:="C:\Users\Meg\Desktop\Master File.xlsx", ReadOnly:=True)
Dim SheetB As Worksheet
Dim lastrow As Long
Set SheetB = WbB.Sheets("Sheet1")
SheetB.Select
Rows("1:1").Select
'Selection.AutoFilter
'ActiveSheet.Range("A:V").AutoFilter Field:=20, Criteria1:=""
Columns("A:V").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("today").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Columns("A:X").Select
'ActiveSheet.Range("$A$1:$X$750001").RemoveDuplicates Columns:=Array(3, 4, 6), _
Header:=xlYes
Application.CutCopyMode = False
lastrow = Sheets("today").Range("D" & Rows.Count).End(xlUp).Row
Sheets("today").Cells(lastrow, 3).EntireRow.Delete
WbB.Close False
End If
End Sub
Sub dltnew()
Dim i As Long
Dim lrow As Long
lrow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lrow
If Sheets("today").Cells(i, 2).Value = "NEW" Then
Sheets("today").Cells(i, 2).Value = ""
Sheets("today").Cells(i, 1).Value = ""
End If
Next i
End Sub
Sub comdate()
Dim Sheet1 As Worksheet
Dim Sheet3 As Worksheet
Dim lrow As Long
Dim i As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
Set Sheet3 = ThisWorkbook.Sheets("today")
Sheet3.Range("A1").Value = Date
Sheet3.Range("A1").NumberFormat = "dd/mm/yyyy"
Sheet3.Range("A1").Font.Color = Sheet3.Range("A1").Interior.Color
Sheet3.Columns("A:A").EntireColumn.Hidden = False
If Sheet1.Range("B1").Value <> Sheet3.Range("A1").Value Then
Sheet1.Range("B1").Value = Sheet3.Range("A1").Value
lrow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lrow
If Sheet1.Cells(i, 2).Value = "NEW" Then
Sheet1.Cells(i, 2).Value = ""
End If
Next i
End If
End Sub
Sub Con()
Dim LasRow As Long
Application.ScreenUpdating = False
LasRow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row
Sheets("today").Range("A2:A" & LasRow).Formula = "=C2&G2&I2"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Sub Compare()
Dim mrow As Range, trow As Long
With Worksheets("main")
Set mrow = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With
trow = Worksheets("today").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("today")
For j = 2 To trow
If mrow.Find(What:=.Range("A" & j).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing _
Then .Range("B" & j).Value = "NEW"
Next j
End With
End Sub
Sub getnew()
Dim Sheet1 As Worksheet
Dim Sheet3 As Worksheet
Dim lastrow As Long
Dim i As Long
Dim erow As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
Set Sheet3 = ThisWorkbook.Sheets("today")
lastrow = Sheet3.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheet3.Cells(i, 2).Value = "NEW" Then
erow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row + 1
Sheet3.Cells(i, 2).EntireRow.Copy Destination:=Sheet1.Range("A" & erow)
Application.CutCopyMode = False
Sheet1.Select
Range("A1:X750001").Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End If
Next i
End Sub
Sub hidecellvalue()
Dim Sheet1 As Worksheet
Dim lastrow As Long
Dim k As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
lastrow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
For k = 2 To lastrow
If Sheet1.Cells(k, 1).Value <> "NEW" Then
Sheet1.Cells(k, 1).Font.Color = Sheet1.Cells(k, 1).Interior.Color
'Sheet1.Columns("A:A").EntireColumn.Hidden = False
End If
Next k
End Sub
Sub hideSh1column()
Dim Sheet1 As Worksheet
Set Sheet1 = ThisWorkbook.Sheets("main")
Sheet1.Columns("A:A").EntireColumn.Hidden = True
Sheet1.Columns("D:F").EntireColumn.Hidden = True
Sheet1.Columns("H:H").EntireColumn.Hidden = True
Sheet1.Columns("L:L").EntireColumn.Hidden = True
Sheet1.Columns("N:N").EntireColumn.Hidden = True
Sheet1.Columns("P:P").EntireColumn.Hidden = True
End Sub
Sub HideSheet3()
Sheets("today").Visible = xlSheetVisible
End Sub
I would start with remove as much as .activate and select you have in your code and replace it with proper sheet.cell/range selection.
Then i would add this on beggining of your code
Dim previousScreenUpdating As Boolean
previousScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim previousCalculation As XlCalculation
previousCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
and this on the end of your code
Application.ScreenUpdating = previousScreenUpdating
Application.Calculation = previousCalculation
This should be much faster.
You should always try to do as much using arrays as possible, rather than going through your data cell-by-cell.
In addition, a dictionary-based lookup is always going to beat using Find() when you're checking things in a large loop.
Sub Compare()
Dim mrow As Range, trow As Long, arr, r As Long
Dim d As Object, rngV As Range
Dim arrV, arrN, wsT As Worksheet, wsM As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Set wsM = Worksheets("Main")
Set wsT = Worksheets("today")
'get all unique values in ColA on Main
arr = wsM.Range(wsM.Range("A2"), wsM.Cells(wsM.Rows.Count, 1).End(xlUp)).Value
For r = 1 To UBound(arr, 1)
d(arr(r, 1)) = 1
Next r
Set rngV = wsT.Range(wsT.Range("A2"), wsT.Cells(wsT.Rows.Count, 1).End(xlUp))
arrV = rngV.Value 'values from colA as array
arrN = rngV.Offset(0, 1).Value 'values from colB as array
'check colA against the dictionary and update colB array as needed
For r = 1 To UBound(arrV, 1)
If Not d.exists(arrV(r, 1)) Then arrN(r, 1) = "NEW"
Next r
'repopulate ColB with updated data
rngV.Offset(0, 1).Value = arrN
End Sub
I have a problem in the loop. I want to import lines that contain "X" in their first cell but :
It doesn't paste them from the first row
It pastes them too many times
Can someone help me ?
Sub refresh()
'
' refresh Macro
'
' Touche de raccourci du clavier: Ctrl+y
'
Dim LastRow As Integer, i As Integer
Dim wksSrc As Worksheet, wksDest As Worksheet
Dim lngRow As Long
Set wksSrc = ThisWorkbook.Worksheets("Scénarios de menace")
Set wksDest = ThisWorkbook.Worksheets("Analyse de risque S")
Application.Calculation = xlAutomatic
Application.DisplayAlerts = False
wksDest.Range("A6:AP1000").Delete
Application.DisplayAlerts = True
wksDest.Range("A6:AP1000").ClearContents 'Works directly, without selection
lngRow = wksDest.Cells(wksDest.Rows.Count, 2).End(xlUp).Row + 1
For i = 2 To wksSrc.Range("A" & wksSrc.Rows.Count).End(xlUp).Row
If wksSrc.Cells(i, 1) = "X" Then
wksSrc.Range(wksSrc.Cells(i, 2), wksSrc.Cells(i, 20)).Copy
wksDest.Range("B" & lngRow).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
lngRow = lngRow + 1
End If
Next i
End Sub
sub refresh()
Dim LastRow As Integer, i As Integer
Dim wksSrc As Worksheet, wksDest As Worksheet
Dim lngRow As Long
Set wksSrc = ThisWorkbook.Worksheets("Scénarios de menace")
Set wksDest = ThisWorkbook.Worksheets("Analyse de risque S")
wksDest.Range("A6:AP1000").Delete
wksDest.Range("A6:AP1000").ClearContents 'Works directly, without selection
lngRow = 6
LastRow = wksSrc.Range("A" & wksSrc.Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If wksSrc.Cells(i, 1) = "X" Then
wksSrc.Range(wksSrc.Cells(i, 2), wksSrc.Cells(i, 20)).Copy
wksDest.Range("B" & lngRow).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
lngRow = lngRow + 1
End If
Next i
end sub
This version is optimized (not using a For loop)
Option Explicit
Public Sub refreshAnalyse()
Dim ws1 As Worksheet, ws2 As Worksheet, lr1 As Long
Set ws1 = ThisWorkbook.Worksheets("Scénarios de menace")
Set ws2 = ThisWorkbook.Worksheets("Analyse de risque S")
ws2.Range("B6:AP" & ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row).Clear
lr1 = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
ws1.Range("A1:A" & lr1).AutoFilter Field:=1, Criteria1:="x"
ws1.Range("B2:AP" & lr1).SpecialCells(xlCellTypeVisible).Copy
ws2.Range("B6").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ws1.Range("A6:A" & lr1).AutoFilter
ws2.Activate: ws2.Cells(1, 1).Activate
Application.ScreenUpdating = True
End Sub