Related
Sub Macro1()
Sheet2.Select
ActiveWindow.SmallScroll Down:=-69
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Dim Endrow&
Endrow = Sheet3.Range("H1").End(xlDown).Row
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Sheet3.Name & "!R1C8:R" & Endrow & "C21", Version:=6).CreatePivotTable _
**TableDestination:=Sheets("Sheet2").Cells(1, 1)**, TableName:= _
"PivotTable1", DefaultVersion:=6
I tried to make this Pivot Tables Macro insert into Sheet2!R1C1 (which is an existing worksheet), instead of creating a new worksheet. However, I receive Run-time error
5: Invalid Procedure call or argument.
I have tried to following methods
TableDestination:=Sheets("Sheet2").Cells(1, 1)
TableDestination:="Sheet2!R1C1"
TableDestination:=Sheet2.name & "!R1C1"
but all failed. How can I make this right?
Your code works on the assumption that there are worksheets with the Code Name (not names!) of Sheet2 and Sheet3. Could it be that you're referring to the sheet's object name which possibly has changed? This works … if you have a Sheet2 and Sheet3
Sub Macro1()
Sheet2.Select
ActiveWindow.SmallScroll Down:=-69
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Dim Endrow&
Endrow = Sheet3.Range("H1").End(xlDown).Row
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Sheet3.Name & "!R1C8:R" & Endrow & "C21", Version:=6).CreatePivotTable _
TableDestination:=Sheets("Sheet2").Cells(1, 1), TableName:= _
"PivotTable1", DefaultVersion:=6
End Sub
Perhaps check that when you refer to Sheet2 and Sheet3 that they still exists.
Public Sub ListSheetNames()
Dim vSheet As Worksheet
For Each vSheet In Worksheets
Debug.Print "Code Name/Sheet Name: " & vSheet.CodeName & " / " & vSheet.Name
Next
End Sub
Maybe change Sheet2 reference to the below … and similarly for Sheet3
sheets("Sheet2")
I have this macro that takes all of sheet1 and creates a pivot table of it. However, it is currently only looking at the amount of rows I had when I made it and not the entire sheet no matter how many rows it has that day. Is there any way to make it select all of sheet1 as the pivot table data every time?
If possible I would also like to alter the fix duplicates to be the entire column based on the column name (IDNUMBER) if able.
Range("$A$1:$AM$2428")
Range("$A$1:$AM$4000")
"PIVOT_STATE_REPORT!R1C1:R1048576C39"
Sub PIVOT_STATE()
'
' PIVOT_STATE Macro
'
'
'ActiveSheet.Range("$A$1:$AM$2428").RemoveDuplicates Columns:=36, Header:= _
'xlYes
Columns("AJ:AJ").Select
ActiveSheet.Range("$A$1:$AM$4000").RemoveDuplicates Columns:=36, Header:= _
xlYes
Range("A2").Select
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"PIVOT_STATE_REPORT!R1C1:R1048576C39", Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion15
Sheets("Sheet1").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("State (Corrected)")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Count"), "Sum of Count", xlSum
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Claim Age in CS"), _
"Sum of Claim Age in CS", xlSum
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Days Since LHN"), _
"Sum of Days Since LHN", xlSum
Range("B3").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of Count")
.Caption = "Count of Count"
.Function = xlCount
End With
Range("C3").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
"Sum of Claim Age in CS")
.Caption = "Average of Claim Age in CS"
.Function = xlAverage
.NumberFormat = "0"
End With
Range("D3").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
"Sum of Days Since LHN")
.Caption = "Average of Days Since LHN"
.Function = xlAverage
.NumberFormat = "0"
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("State (Corrected)")
End With
End Sub
Thanks in advance!
I would use the last row and column formulas provided in this function.
Then make the source a combo of these variables.
Function LastRowColumn(sht As Worksheet, RowColumn As String) As Long
'PURPOSE: Function To Return the Last Row Or Column Number In the Active
Spreadsheet
'INPUT: "R" or "C" to determine which direction to search
Dim rc As Long
Select Case LCase(Left(RowColumn, 1)) 'If they put in 'row' or column instead of 'r' or 'c'.
Case "c"
LastRowColumn = sht.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Case "r"
LastRowColumn = sht.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Case Else
LastRowColumn = 1
End Select
End Function
Then inside of your macro call out:
x = LastRowColumn(ActiveSheet, "column")
y = LastRowColumn(ActiveSheet, "Row")
plast = cells(x,y)
Then make a range based off that for the source of the pivot table
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"PIVOT_STATE_REPORT!A1:" & plast, Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion15
I think the easiest way of doing this will be to replace these lines of your code
Columns("AJ:AJ").Select
ActiveSheet.Range("$A$1:$AM$4000").RemoveDuplicates Columns:=36, Header:=xlYes
Range("A2").Select
With
Dim rData As Range: Set rData = ActiveSheet.Range("A1", ActiveSheet.Range("A1").End(xlDown))
Set rData = Range(rData, rData.End(xlToRight))
rData.RemoveDuplicates Columns:=36, Header:=xlYes
ActiveWorkbook.PivotCaches.Create SourceType:=xlDatabase, SourceData:=rData
The update this be where you make your PivotCache
`
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"PIVOT_STATE_REPORT!R1C1:R1048576C39", Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion15c
`
With the following code using the rData range as the Source Data
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
rData, Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion15
Note this assumes that there are no gaps in the columns or rows of your Data. The End(xlDown) is the equivalent of holding the Ctrl and Down key
I have an automated filed that comes out with a row (4) of headers
the first column (A) contains different categories (types of payment), in base of the specific type I would run a different test based on a certain sheet contained into the file I'm working on.
What am I doing at the moment is basically create a filter (of the first column A) based on the type of payment I want to check, create a temporary sheet, copy paste this filtered view, work on that with the checks and then copy/paste the result (contained in the column R) into the main sheet.
The problem comes out in the last part, when I want to copy paste, because of the filtered view I can't Just go to the first free cell under the header of R and copy paste, because the system doesn't understand I'm moving into a filtered view. I have to be sure that I'm copy pasting the correct results in base of the value (string) contained into the A column), can you help me to solve it please?.
Another way is to do a for each loop, but actually I'm not sure about how to structure it.
Here we have the part of the code i'm working on
Sub Payexample()
' normal cleaning procedures
Sheets("Payexample").Select
Rows("1:10").Select
Selection.Delete Shift:=xlUp
Columns("J:J").Select
Selection.Replace What:="AED", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.NumberFormat = "0.00"
Sheets("Sheet1").Select
ActiveSheet.Range("$A$4:$A$500").AutoFilter Field:=1, Criteria1:="Payfort"
Range("A5 : N5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Payfort momentary"
Range("A1").Select
ActiveSheet.Paste
Range("$M$1").Formula = Range("B1") & (",") & Range("M1")
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Range("J" & Rows.Count).End(xlUp).Row
Range("O1").FormulaR1C1 = "=IF(RC[-2]-VLOOKUP(RC[-3],'PayFort'!B:J,9,FALSE)<=0.99, ""Payfort Payment Checked"", ""Manual Verification Needed"")"
Range("O1").AutoFill Destination:=Range("O1:O" & Lastrow)
Range("O1:O" & Lastrow).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Range("$A$4:$A$500").AutoFilter Field:=1, Criteria1:="Payfort"
Range("R5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Sheets("Payfort Momentary").Select
'ActiveWindow.SelectedSheets.Delete
End Sub
I think this will do mostly what you are after but I wasn't sure what you want to do with your formulas, hopefully you'll be able to work out what you want to do with them from here:
Sub Payexample()
Dim rngCheck As Range
Dim r As Range
Dim rowNum As Long
' normal cleaning procedures
Sheets("Payexample").Select
Rows("1:10").Select
Selection.Delete Shift:=xlUp
Columns("J:J").Select
Selection.Replace What:="AED", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.NumberFormat = "0.00"
Sheets("Sheet1").Select
With ActiveSheet
rngCheck = .Range("$A$4:$A$500")
For Each r In rngCheck.Rows ' Loop through the rows in your data area
rowNum = r.Row
If .Range("A" & rowNum) = "Payfort" Then
' Either
.Range("R" & rowNum).Formula = "" ' Your formula here
.Range("R" & rowNum) = .Range("R" & rowNum).Value ' Change formula to value
' Or
.Range("R" & rowNum) = ' Do calculations in VBA without formula
End If
Next r
End With
End Sub
I am hoping someone can help me in my dilemma. Due to a system software limitation, I need to have all my code in one Macro.
1.) take Column Q which is a name in the format "last, first" and break it up using text to column (some names contain initials which is why I used text to column)
2.) include code to dismiss the message box that appears "Do you want to replace the contents of the destination cells?"
3.) delete all columns that are generated except the "last" & "first" name.
4.) concatenate the two columns so that they read Firstname Lastname
5.) auto fill down to the last row.
6.) copy paste special the values into an adjacent column and delete the old column with the function.
I tried recording the code but it seems that what I need can't be recorded and needs to be written.
Here's my shot at get those steps to work, pulled from code from my recorder as well as forums, and think I need a trained eye to sort through my mess:
Application.DisplayAlerts = False
Columns("Q:Q").Select
Selection.TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=True, Comma:=True, Space:=True, Other:=False, FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
True
Application.DisplayAlerts = False
Columns("U:U").Select
Selection.Delete Shift:=xlToLeft
Columns("S:T").Select
Selection.ClearContents
Range("S2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1], "" "", RC[-2])"
Range("S2").Select
Selection.AutoFill Destination:=Range("S2:500")
Range("S2:S42").Select
Columns("S:S").Select
Selection.Copy
Columns("T:T").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("T1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Lead Recruiter"
Columns("Q:S").Select
Selection.Delete Shift:=xlToLeft
Thanks to Ron, I was able to get the msg box to dismiss. Right now it's break at the line:
Selection.AutoFill Destination:=Range("S2:500")
How can I update this to Autofill to the last row? The data is in column Q. Any insight is greatly appreciated.
My Assumptions
Data is in Column Q
There is no data after Column Q
The results needs to be generated in Column R. If you want to replace the values in Column Q then see CODE 2.
Here is the shortest code that I could think of.
CODE 1
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in a column
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in the complete column
.Range("R1:R" & lRow).Formula = "=IFERROR(MID(Q1,FIND("","",Q1,1)+2,FIND("" "",Q1,FIND("","",Q1,1)+2)-" & _
"(FIND("","",Q1,1)+2)),MID(Q1,FIND("","",Q1,1)+2,LEN(Q1)-FIND("","",Q1" & _
",1)+2+1)) & "" "" & LEFT(Q1,FIND("","",Q1,1)-1)"
'~~> Convert all formulas to values in one go
.Range("R1:R" & lRow).Value = .Range("R1:R" & lRow).Value
End With
End Sub
ScreenShot
CODE 2
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in a column
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in the complete column
.Range("R1:R" & lRow).Formula = "=IFERROR(MID(Q1,FIND("","",Q1,1)+2,FIND("" "",Q1,FIND("","",Q1,1)+2)-" & _
"(FIND("","",Q1,1)+2)),MID(Q1,FIND("","",Q1,1)+2,LEN(Q1)-FIND("","",Q1" & _
",1)+2+1)) & "" "" & LEFT(Q1,FIND("","",Q1,1)-1)"
'~~> Convert all formulas to values in one go
.Range("R1:R" & lRow).Value = .Range("R1:R" & lRow).Value
'~~> Delete Col Q so R moves to Q
.Columns(17).Delete Shift:=xlToLeft
End With
End Sub
Followup from Comments
Is this what you are trying?
Sub FormatPushReport()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("R:R,U:U").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("R1").Value = .Range("Q1").Value
.Range("V1").Value = .Range("U1").Value
'~~> Find the last row in a column
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in the complete column
.Range("R2:R" & lRow).Formula = "=IFERROR(MID(Q2,FIND("","",Q2,1)+2,FIND("" "",Q2,FIND("","",Q2,1)+2)-" & _
"(FIND("","",Q2,1)+2)),MID(Q2,FIND("","",Q2,1)+2,LEN(Q2)-FIND("","",Q2" & _
",1)+2+1)) & "" "" & LEFT(Q2,FIND("","",Q2,1)-1)"
.Range("V2:V" & lRow).Formula = "=IFERROR(MID(U2,FIND("","",U2,1)+2,FIND("" "",U2,FIND("","",U2,1)+2)-" & _
"(FIND("","",U2,1)+2)),MID(U2,FIND("","",U2,1)+2,LEN(U2)-FIND("","",U2" & _
",1)+2+1)) & "" "" & LEFT(U2,FIND("","",U2,1)-1)"
'~~> Convert all formulas to values in one go
.Range("R2:R" & lRow).Value = .Range("R2:R" & lRow).Value
.Range("V2:V" & lRow).Value = .Range("V2:V" & lRow).Value
.Columns(18).Replace What:="#VALUE!", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
.Columns(22).Replace What:="#VALUE!", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
.Range("Q:Q,U:U").Delete Shift:=xlToLeft
End With
End Sub
Screenshot
Hello again and thank you for time !
I have the following code that would not let me work in peace - although I am no VBA power I have managed to put this together in about a week or so.
After launching the macro, most of the times I must not touch excel at all for ~2 minutes but I do have occasions for which it closes by itself ...
Sub Filter()
'
' substitute Macro
Application.ScreenUpdating = False
Selection.Copy
ActiveWindow.ActivateNext
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "buffer"
Dim wsS As Worksheet, wsN As Worksheet, i As Integer, j As Integer, k As Integer, l As Integer
Set wsS = Sheets("buffer")
Set wsN = Sheets("non_confid")
colA = "A"
colB = "B"
colC = "C"
colE = "E"
i = 2
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.Replace What:=" ", Replacement:=","
Range("A1").Copy
Range("z1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Columns("A:y").Select
Range("F25").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B1").FormulaR1C1 = "=SUBSTITUTE(RC[-1],CHAR(13),"";"")"
Range("C1").FormulaR1C1 = "=SUBSTITUTE(RC[-1],CHAR(10),"";"")"
Range("D1").FormulaR1C1 = "=substitute(rc[-1],""/"","";"")"
Range("e1").FormulaR1C1 = "=substitute(rc[-1],""consultant"","";"")"
Range("f1").FormulaR1C1 = "=substitute(rc[-1],""dessinateur"","";"")"
Range("g1").FormulaR1C1 = "=substitute(rc[-1],""grp"","";"")"
Range("h1").FormulaR1C1 = "=substitute(rc[-1],""projet"","";"")"
Range("i1").FormulaR1C1 = "=substitute(rc[-1],""Inscrire dans ce pavé les projets ou familles concernés"","";"")"
Range("j1").FormulaR1C1 = "=substitute(rc[-1],""Inscrire dans ce pavé les profils demandés"","";"")"
Range("k1").FormulaR1C1 = "=substitute(rc[-1],""Droits en consultation"","";"")"
Range("l1").FormulaR1C1 = "=substitute(rc[-1],""Droits en création"","";"")"
Range("m1").FormulaR1C1 = "=substitute(rc[-1],"":"","";"")"
Range("n1").FormulaR1C1 = "=substitute(rc[-1],""("","";"")"
Range("o1").FormulaR1C1 = "=substitute(rc[-1],"")"","";"")"
Range("p1").FormulaR1C1 = "=substitute(rc[-1],""profil"","";"")"
Range("q1").FormulaR1C1 = "=substitute(rc[-1],""non,confid"","";"")"
Range("r1").FormulaR1C1 = "=substitute(rc[-1],"" "","";"")"
Range("r1").Copy
Range("s2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("A:r").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=True, Comma:=True, Space:=False, OtherChar:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1))
Range(Selection, Selection.End(xlToRight)).Copy
Range("A2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("A:A").EntireColumn.AutoFit
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("a1").FormulaR1C1 = "Sorted"
Range("a1").Select
ActiveSheet.Range("$A$1:$A$300").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$a$500"), , xlYes).Name = "Table1"
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="<>"
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(IF(ISNA(MATCH([#Sorted],NPDM[Contexte],0)),IF(FIND(""."",[#Sorted]),[#Sorted],""""),""""),"""")"
Range("B1").FormulaR1C1 = "Formula"
Range("Table1[Formula]").Select
Selection.Copy
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B1").FormulaR1C1 = "Dot"
Range("Table1[Dot]").Select
Selection.TextToColumns Destination:=Range("Table1[[#Headers],[Dot]]"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
:=True, Tab:=True, Semicolon:=True, Comma:=True, Space:=False, Other _
:=True, OtherChar:=".", FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
TrailingMinusNumbers:=True
Range("C1").FormulaR1C1 = "nDot"
Range("B1").FormulaR1C1 = "Dot"
Range("Table1[Dot]").Select
Selection.Copy
Range("A250").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
Range("Table1[nDot]").Select
Selection.Copy
Range("A500").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
Range("B:C").EntireColumn.Delete
For j = 2 To 300
If Not IsEmpty(wsS.Range(colA & j).Value) Then
wsS.Range(colC & i - 1).Value = wsS.Range(colA & j).Value
i = i + 1
End If
Next
Range("A:B").EntireColumn.Delete
For k = 1 To 300
If Not IsEmpty(wsS.Range(colA & k).Value) Then
wsN.Range(colE & i).Value = wsS.Range(colA & k).Value
i = i + 1
End If
Next
Sheets("non_confid").Select
Columns("A:G").EntireColumn.AutoFit
Range("e1").Select
ActiveSheet.ListObjects("Status").Range.AutoFilter Field:=4, Criteria1:="<>"
Range("E2").Select
ActiveWorkbook.Worksheets("non_confid").ListObjects("Status").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("non_confid").ListObjects("Status").Sort.SortFields. _
Add Key:=Range("Status[ce ?]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("non_confid").ListObjects("Status").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Application.DisplayAlerts = False
Sheets("buffer").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
End Sub
PS - since my team mates will be working with this, is there a way for this macro to work on a PC that is in French ? because in an earlier version was not (making "Feuil1" while looking for "Sheet1" and putting formulas in English instead of translating them). As I understood, the macro convert automatically to an universal programming language to be read wherever they are opened.
Cor_Blimey gave you some great information above. I will add to this.
Your code can probably be improved if you learn to avoid the Select and Activate methods (which force you to rely on bulkier, cumbersome code that takes longer to execute). It also makes for code that is not as easily legible, because it's not as object-oriented.
Also, many people rely unnecessarily on Copy & Paste methods, when that can also usually be avoided.
Here is one such example, where you copy a range and then paste values to another range:
Range("A1").Copy
Range("z1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
This can be simplified like:
Range("Z1").Value = Range("A1").Value
Here is an example of unnecessary Select method:
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
These three lines of code can be replaced with one statement:
Rows("1:1").EntireRow.Delete
And another (there are several examples of such):
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(IF(ISNA(MATCH([#Sorted],NPDM[Contexte],0)),IF(FIND(""."",[#Sorted]),[#Sorted],""""),""""),"""")"
In the above, you first select/activate a cell, and then you operate on the ActiveCell. This is unnecessary, you can simply operate on the object directly:
Range("B2").FormulaR1C1 = "=IFERROR(IF(ISNA(MATCH([#Sorted],NPDM[Contexte],0)),IF(FIND(""."",[#Sorted]),[#Sorted],""""),""""),"""")"
THese are some helpful coding practices. Otherwise, #Cor_Blimey's answer above is very good. The Application.ScreenUpdating should speed up the execution time, and if possible, setting Application.Calculation = xlManual will also help. However, the .Calculation method might not be an option in this case, since you may be relying on interim calculations as you're moving .Values from one range to another.
For non english languages, you could use .FormulaLocal or .FormulaR1C1Local. Developer reference says "Returns or sets the formula for the object, using R1C1-style notation in the language of the user. Read/write Variant".
However, I strongly recommend not using the above, as it will mean it won't work if the macro is run on a different language version. Instead, better practice is to use English in conjunction with .Formula and .FormulaR1C1. This will still open as French in a French version, as Excel automatically displays formulae text in the relevant language.
For example: (I use "FALSE" only as an example - the below is true for formulae too like "=SUM(A1)", and of course, if you really want to set a boolean value then please don't use string "TRUE"!)
ActiveCell.Formula = "FALSE"
Ok - Locale independent - This will be a FALSE boolean value displayed as FALSE in English and displayed as FAUX in French, but in both cases it is a Boolean value
ActiveCell.FormulaLocal = "FAUX"
'Bad - Locale dependent! - This will be a String "FAUX" if the macro is run on an English version,
but a boolean FALSE if run on a French version
ActiveCell.Formula = "FAUX"
'Locale independent, but probably not what you want - This will be a String "FAUX" in all languages
You should not hard-code referring to a sheet by something like "Feuil1". This is just a string name, and Excel will not adapt for the User's locale. Instead, when you add a new sheet, immediately assign it to a worksheet variable, then use that.
For example:
'Bad: it might work if the workbook is made on a French version but it won't on English and vice versa
Worksheets("Feuil1").Activate
Worksheets("Sheet1").Activate 'also bad
'Better:
Worksheets(1).Activate
'or
With Worksheets.Add
.Name = "Results"
.Activate
End With
'or (for use outside a With block)
Set resultsWs = Worksheets.Add
As for the rest - I am afraid I do not know what your question is. It is probably crashing sometimes because you are using lots of cut/copy - if it is a very large worksheet or with lots of formulae that recalculate each cut/insert this will take a long time. Unless you need intermediate calculations, disable calculation and screen updating at the start and only re-enable at the end (using Application.ScreenUpdating = False, and Application.Calculation = XLManual)