I am quite inexperienced with vba and I am trying to make a code.
I am running it and it works fine but it is too slow when I have many rows. And with slow I mean that it could be running for minutes. I didnt waited till the end yet.
I would be very grateful for some help
Sub importart_lv()
Application.ScreenUpdating = False
Dim CL As Range
Dim rng As Range: Set rng = ActiveSheet.Range("A1:A2500")
For Each Cell In rng.Cells
If Cell.Value = "Position" Then
Cell.Offset(0, 6).Select
Worksheets("Bausteine").Activate
Range("G9:U9").Select
Selection.Copy
Worksheets("LV-Importieren").Activate
Selection.Insert
FindReplace
End If
'Cell.Offset(0, 11).Value = IIf(InStr(1, Cell, "Position"), "True", "")
Next
Application.CutCopyMode = False
ActiveSheet.Range("J1").Select
Worksheets("Bausteine").Activate
Range("G8:U8").Select
Selection.Copy
Worksheets("LV-Importieren").Activate
Selection.Insert
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Related
Am having difficulty enhancing my code to remove the "SELECT" option and use the ASSIGNMENT. Meaning to change from the SELECT, COPY and PASTE to the assigning Values Directly. Am an absolute beginner, if anyone could lead me through. My main issue is in the loop, however, here is the full code, any suggestion, recommendation is welcomed, just to make it more efficient!
Here is my code:
Sub LINK_ANALYSIS()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim NumberOfColumns As Integer
Dim rng As Range
NumberOfColumns = ActiveSheet.UsedRange.Columns.Count
Sheets("Sheet2").Range("A1").Value2 = Sheets("Sheet1").Range("A1").Value2
Sheets("Sheet2").Range("A2:B2").Value2 = "SUBJECT"
Let x = 4
Do While x <= NumberOfColumns
ActiveSheet.UsedRange.AutoFilter Field:=x, Criteria1:="1", Criteria2:="2", Operator:=xlOr
ActiveSheet.UsedRange.Cells(2, x).Select
Set rng = Range(Cells(ActiveCell.Row + 1, ActiveCell.Column), Cells(Rows.Count, ActiveCell.Column))
rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
If ActiveCell.Value >= "1" Then
Cells(1, (x - 1)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Application.CutCopyMode = False
Range("A1").Select
End If
ActiveSheet.UsedRange.AutoFilter Field:=x
x = x + 2
Loop
Sheets("Sheet2").Select
ActiveSheet.Cells.EntireColumn.AutoFit
Range("A1").Select
Sheets("Sheet2").Copy
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
The contention...
If ActiveCell.Value >= "1" Then
Sheets("Sheet2").Range("A2").Selection.End(xlToRight).ActiveCell.Offset(0, 1).Value2 = Cells(1, (x - 1)).Range(Selection, Selection.End(xlDown)).Value2
End If
I expected this assignment code to copy the selected cells in sheet1 and assign them to the selected cell in sheet2
The copy paste code works but, when i make attempt to use the assignment code it return error "out of range". I design the code to filter selected columns on certain criteria and copy the results from the leftcolmn and past to sheet2, the loop continues until the last column.
This demo will be scaled up to perform this operation on data ranges with 100's of rows, so I'm not sure how to make the runtime faster, and avoid selecting different sized ranges using the xlToRight if there was adjacent data. Attached is a view-only xlsm.
spreadsheet
Sub Main_Loop()
' This script references the number of unique items in the
' filter then loops the data extraction based on this value.
'
' Keyboard Shortcut: Ctrl+Shift+Z
'
' Nate_Ayers
Application.ScreenUpdating = False
Range("H1").Select
Dim i As Integer 'counter
Dim Loop_var As String
Loop_end = Range("A2").Value2 'Stop loop at end of unique items
For i = 1 To Loop_end
Selection.Copy
Range("A3").Select 'Helper cell location chosen where data wont overwrite the cell
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Paste values only (avoids unique function)
Application.CutCopyMode = False
Selection.Copy
Columns("C:C").AutoFilter
ActiveSheet.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
'Data block grab:
Range("C2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A2").Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Worksheets(ActiveSheet.Index).Select 'could have efficiency improvement
Worksheets(ActiveSheet.Index).Name = Selection 'Name the sheet
Range("A1").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Demo").Select
Range("A3").Select
Selection.ClearContents
Selection.AutoFilter
Range("H1").Select
ActiveCell.Offset(0, i).Select 'Reference next row to repeat operations
Next i
Application.ScreenUpdating = True
End Sub
It's hard to know what some of your subroutine is doing without seeing the underlying spreadsheet, and some of the variables don't seem to be referenced. But here are a few examples of how you might be able to speed things up. As already mentioned the main issue is the unnecessary use of copy and paste. This probably won't be a solution that works, but I hope it helps you on the way.
Sub Main_Loop()
Dim vCalc, vEvents As Variant
Dim ws, new_ws As Worksheet
Dim i As Integer 'counter
Application.ScreenUpdating = False
vCalc = Application.Calculation
Application.Calculation = xlCalculationManual
vEvents = Application.EnableEvents
Application.EnableEvents = False
Set ws = ActiveSheet
i = 1
While ws.Range("H" & i) <> ""
ws.Range("A3").Value = ws.Range("H" & i).Value
ws.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
Set new_ws = Sheets.Add(After:=ActiveSheet)
ws.Range("C2").CurrentRegion.Copy
new_ws.Range("A2").Paste
new_ws.Name = new_ws.Range("A2").Value
new_ws.Range("A1").Value = new_ws.Range("A2").Value
new_ws.Range("A1").Font.Bold = True
i=i+1
Wend
ws.Range("A3").ClearContents
Application.ScreenUpdating = True
Application.Calculation = vCalc
Application.EnableEvents = vEvents
End Sub
I export a schedule from MS Teams to Excel for data manipulation.
I made a macro that changes the dates field to a date format for the EU and sorts by it by date.
Then it goes to the next worksheet and checks the names of employees and creates a worksheet for each of the names.
Then it jumps back to the first worksheet, sorts by "name" criteria and copies the data for every single one to its own respective worksheet.
This is what I got so far that is OK:
Sub Temp1()
'Convert Cell Format from Text to Date and change MDY to DMY Format
Sheets("Shifts").Select
Range("D2:D1000").Select
Selection.TextToColumns Destination:=Range("D2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
Range("F2:F1000").Select
Selection.TextToColumns Destination:=Range("F2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
'Add the Sheets for each member of the "Members" Sheet
Sheets("Members").Select
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A2:A22")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
ActiveCell.FormulaR1C1 = "Evidencija radnog vremena"
Selection.Font.Size = 20
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Godina i mjesec"
Selection.Font.Size = 14
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Radnik"
Selection.Font.Bold = True
ActiveCell.Offset(2, 0).Range("A1").Select
On Error Resume Next
ActiveSheet.Name = xRg.Value
Range("B2").Value = ActiveSheet.Name
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
'Sort by Date
Sheets("Shifts").Select
Range("A1").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
After this I need some kind of loop or switch case or Foreach - i don't know what exactly.
I have it hardcoded for now, but it will become bulky, slow and problematic to maintain.
What I need to do:
Go through the list of employees, find for the employee all data and copy it to his respective worksheet - which has already been created.
Here is the hardcoded version of the code:
ActiveSheet.Range("$A$1:$L$276").AutoFilter Field:=1, Criteria1:= _
"Employee name"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Employee name").Select
ActiveSheet.Paste
ActiveSheet.PageSetup.Orientation = xlPortrait
Columns("A:L").AutoFit
For Each r In Range("I:I").SpecialCells(xlCellTypeConstants)
r.Interior.ColorIndex = xlNone
If r.Value Like "*Home Office*" Then r.Interior.Color = vbGreen
If r.Value Like "*Neradni dan*" Then r.Interior.Color = vbRed
If r.Value Like "*Bolovanje*" Then r.Interior.Color = vbBlue
If r.Value Like "*Godišnji odmor*" Then r.Interior.ColorIndex = 29
Next
Columns("L").EntireColumn.Delete
Columns("J").EntireColumn.Delete
Columns("H").EntireColumn.Delete
Columns("C").EntireColumn.Delete
Columns("B").EntireColumn.Delete
Columns("G").EntireColumn.Delete
I copied the whole code below.
A clarification of what it needs to do:
sort the data in the first worksheet - already handled
create the worksheets by the names in the 3rd worksheet - working
On the first sheet, that is already "sorted" - I need to go through all the names, copy the the data that is relevant to the sheet - i.e the sheets are named by names that are found in row a. so i need it to go through the first worksheet, need all the data that has the same name in the row a and copy it to the respective sheet. - PLEASE HELP :)
Sub TEMPExcelObradiTablicuZaObracunPlaca()
'Convert Cell Format from Text to Date and change MDY to DMY Format
Sheets("Shifts").Select
Range("D2:D1000").Select
Selection.TextToColumns Destination:=Range("D2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
Range("F2:F1000").Select
Selection.TextToColumns Destination:=Range("F2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
'Ovdje dodajem potrebne Sheetove iz Members Sheeta
Sheets("Members").Select
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A2:A22")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
ActiveCell.FormulaR1C1 = "Evidencija radnog vremena"
Selection.Font.Size = 20
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Radnik"
Selection.Font.Size = 14
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Godina i mjesec"
Selection.Font.Bold = True
ActiveCell.Offset(2, 0).Range("A1").Select
'Range("B2).Value = DateAdd(mmmm, yyyy) -> OVDJE SAM ZAPEO TU NASTAVITI!!! - dodavanje datuma u b2 celiju!
On Error Resume Next
ActiveSheet.Name = xRg.Value
Range("B2").Value = ActiveSheet.Name
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
'Sort by Date
Sheets("Shifts").Select
Range("A1").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
'Define LASTROW to find the last row and column in Members Sheetu!
Dim LastRow As Long, LastColumn As Long
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Range("A1").Resize(LastRow, LastColumn).Select
'Proba ForEach petlje
' Creating a range of sheet names from the data on Members
Dim SheetNamesRange As Range
Set SheetNamesRange = Sheets("Members").Range("A2:A" & LastRow)
' Iterate through all sheets in the range and write the word "Updated" in cell B2
Dim SheetName As Variant, SheetNameString As String
For Each SheetName In SheetNamesRange
' OVDJE SAM ISKOMENTIRAO OVA 2 REDA
'SheetNameString = CStr(SheetName)
'ThisWorkbook.Sheets(SheetNameString).Range("Q2") = "Updated"
Sheets("Shifts").Range("$A$1:$L$276").AutoFilter Field:=1, Criteria1:="SheetNameString"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'SheetNameString = CStr(SheetName)
Sheets.CStr(SheetNameString).Select
ActiveSheet.Paste
ActiveSheet.PageSetup.Orientation = xlPortrait
Columns("A:L").AutoFit
For Each r In Range("I:I").SpecialCells(xlCellTypeConstants)
r.Interior.ColorIndex = xlNone
If r.Value Like "*Home Office*" Then r.Interior.Color = vbGreen
If r.Value Like "*Neradni dan*" Then r.Interior.Color = vbRed
If r.Value Like "*Bolovanje*" Then r.Interior.Color = vbBlue
If r.Value Like "*Godišnji odmor*" Then r.Interior.ColorIndex = 29
Next
Columns("L").EntireColumn.Delete
Columns("J").EntireColumn.Delete
Columns("H").EntireColumn.Delete
Columns("C").EntireColumn.Delete
Columns("B").EntireColumn.Delete
Columns("G").EntireColumn.Delete
Next SheetName
End Sub
You are right, a For Each loop can be used here. Here is some code that outlines the basic principle:
Private Sub Shone()
' Creating a range of sheet names from the data on Sheet1
Dim SheetNamesRange As Range
Set SheetNamesRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A3")
' Iterate through all sheets in the range and write the word "Updated" in cell B2
Dim SheetName As Variant, SheetNameString As String
For Each SheetName In SheetNamesRange
SheetNameString = CStr(SheetName)
ThisWorkbook.Sheets(SheetNameString).Range("B2") = "Updated"
Next SheetName
End Sub
In this example, I want to grab the names of sheets written on Sheet1, and write the word "Updated" in cell B2 on each of those sheets.
The cells A1, A2, and A3 on the sheet Sheet1 contain the following text, respectively, "Sheet1", "Sheet2", "Sheet3". First, I create a Range of data. That data is just the sheet names in cells A1:A3. It goes without saying that your Range will contain different data, but I believe that you have already taken care of that part.
Next, I iterate through that Range of data. A For Each loop requires the iterator (in this case, the variable SheetName) to be a Variant datatype. As I iterate through all of the sheets, I finally get to what I want to do: write the word "Updated" in cell B2. Finally, we reach the Next statement which tells us that the next step of the For Each loop will start, if there are any more members in the SheetNamesRange to iterate through.
I need some advice to rectify the code below. I have this code to copy paste lines to another sheet for data compilation purpose. And I'm running well using the with statement below, the problem is, when there's no data to paste, I do not know how to end the code with message box.
I see the similar question above, but how to comply the code into the With statement of VBA below?
Following is the code I read from other user, to return message box if error.
If Err Then
MsgBox "Nothing to paste!"
Err.Clear
End If
My original code, without the Message box return.
*Sub FnLstRow()
Application.ScreenUpdating = False
Dim LR As Long
ThisWorkbook.Worksheets("Data").Select
LR = Cells(Rows.Count, "AO").End(xlUp).Row
Cells(LR, 1).Offset(1, 0).EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("LatestData")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
End Sub**
this is a suboptimal solution that might not work but you could try: I created a dynamic array and tried to pass your entire selection into it. If the selection had no values, it will select all of the remaining cells in the sheet, and it is likely too large to pass into the array, resulting in a run time error. I didn't touch your code except for creating the array and adding the error handling section. I hope it works lol
Sub FnLstRow()
Application.ScreenUpdating = False
Dim LR As Long
Dim Arr() As Variant
ThisWorkbook.Worksheets("Data").Select
LR = Cells(Rows.Count, "AO").End(xlUp).Row
Cells(LR, 1).Offset(1, 0).EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
On Error GoTo Handler
Arr = Selection
On Error GoTo 0
Selection.Copy
With Sheets("LatestData")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
Exit Sub
Handler:
MsgBox "Nothing to paste!"
End Sub
Sub InsertRow()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub
My problem is, when my file is shared with others (share workbook), myself and them can save and everything and add rows, but the thing is the data validation is not copied in the new line and the drop down won't appear.
Anyone can help?
Try this. Your code worked for me so it looks like it might be something related to sharing (as per my comment).
Sub InsertRow()
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
With this code of #Captain Grum
Sub InsertRow()
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
It copies now the data validation below, but the borders and formula won't copy.
Please see this picture
I'm really sorry guys. I'm really just new to programming. I now have the solution to my problems. I just have included the code of #captain grumpy and mine above. Here's the code:
Sub InsertRow()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub