sometimes I don't get Excel VBA, I am just copying data from one sheet to another but I get the error :
pasteSpecial method of Range class failed
I copy some date from a source in the internet, paste it in "temporary" sheet,deleted some columns, do some calculations, and paste it into "final" sheet.
here is my code:
Sub copying()
'
' copying Macro
'
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim tempSheet As Worksheet
Set tempSheet = ThisWorkbook.Sheets("temporary")
tempSheet.Activate
tempSheet.Cells.ClearFormats
tempSheet.Cells(4, 1).Select
ActiveSheet.Paste
Columns(4).Select
Selection.Cut
Columns(3).Select
ActiveSheet.Paste
Columns(6).Select
Selection.Cut
Columns(4).Select
ActiveSheet.Paste
'
Columns(7).Select
Selection.Cut
Columns(5).Select
ActiveSheet.Paste
Columns(8).Select
Selection.ClearFormats
Columns(8).Select
Selection.Cut
Columns(6).Select
ActiveSheet.Paste
Columns(9).Select
Selection.Cut
Columns(7).Select
ActiveSheet.Paste
Columns(19).Select
Selection.Cut
Columns(8).Select
ActiveSheet.Paste
Columns(21).Select
Selection.Cut
Columns(9).Select
ActiveSheet.Paste
Columns(10).Select
Selection.ClearFormats
Selection.ClearContents
Columns(73).Select
Selection.Cut
Columns(11).Select
ActiveSheet.Paste
Columns(23).Select
Selection.Cut
Columns(12).Select
ActiveSheet.Paste
Columns(25).Select
Selection.Cut
Columns(13).Select
ActiveSheet.Paste
Columns(14).Select
Selection.ClearFormats
Selection.ClearContents
Columns(37).Select
Selection.Cut
Columns(21).Select
ActiveSheet.Paste
Columns(22).Select
Selection.ClearFormats
Selection.ClearContents
Columns(76).Select
Selection.Cut
Columns(23).Select
ActiveSheet.Paste
Range("X1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Columns("E:E").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("F:F").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("L:L").Select
Selection.NumberFormat = "0.00"
Columns("H:H").Select
Selection.NumberFormat = "0.00"
Columns(8).Select
Selection.NumberFormat = "0.00"
Columns(9).Select
Selection.NumberFormat = "0.00"
Columns(10).Select
Selection.NumberFormat = "0.00"
Columns(12).Select
Selection.NumberFormat = "0.00"
Columns(13).Select
Selection.NumberFormat = "0.00"
Columns(14).Select
Selection.NumberFormat = "0.00"
Columns(16).Select
Selection.NumberFormat = "0.00"
Columns(17).Select
Selection.NumberFormat = "0.00"
Columns(18).Select
Selection.NumberFormat = "0.00"
Columns(20).Select
Selection.NumberFormat = "0.00"
Columns(21).Select
Selection.NumberFormat = "0.00"
Columns(22).Select
Selection.NumberFormat = "0.00"
' Debug.Print Cells(10, 2)
lrow = Cells(Rows.Count, "C").End(xlUp).row
'debig.Print Cells(2, 9).Value
Dim i As Integer
For i = 5 To lrow
' calculating the UM = NS - CoS
'for SDP3
If (Cells(i, 8).Value = "Missing Data" Or Cells(i, 9).Value = "Missing Data") Then
Cells(i, 10).Value = "Missing Data"
Else
Cells(i, 10).Value = Cells(i, 8).Value - Cells(i, 9).Value
End If
'TG2
If (Cells(i, 12).Value = "Missing Data" Or Cells(i, 13).Value = "Missing Data") Then
Cells(i, 14).Value = "Missing Data"
Else
Cells(i, 14).Value = Cells(i, 12).Value - Cells(i, 13).Value
End If
' PTD
If (Cells(i, 16).Value = "Missing Data" Or Cells(i, 17).Value = "Missing Data") Then
Cells(i, 18).Value = "Missing Data"
Else
Cells(i, 18).Value = Cells(i, 16).Value - Cells(i, 17).Value
End If
' PTE
If (Cells(i, 20).Value = "Missing Data" Or Cells(i, 21).Value = "Missing Data") Then
Cells(i, 22).Value = "Missing Data"
Else
Cells(i, 22).Value = Cells(i, 20).Value - Cells(i, 21).Value
End If
'%UM DEVIATION = UM% of the second - UM%
'SDP3 --- TG2
If (Cells(i, "K").Value = "N/A" Or Cells(i, "O").Value = "N/A") Then
Cells(i, "Y").Value = "N/A"
Else
Cells(i, "Y").Value = Cells(i, "O").Value - Cells(i, "K").Value
End If
'SDP3 --- PTE
If (Cells(i, "K").Value = "N/A" Or Cells(i, "S").Value = "N/A") Then
Cells(i, "AB").Value = "N/A"
Else
Cells(i, "AB").Value = Cells(i, "S").Value - Cells(i, "K").Value
End If
'TG2 -- PTE
If (Cells(i, "O").Value = "N/A" Or Cells(i, "S").Value = "N/A") Then
Cells(i, "AE").Value = "N/A"
Else
Cells(i, "AE").Value = Cells(i, "S").Value - Cells(i, "O").Value
End If
' DEV MSEK if (UM% of both < 0 -> %UM * NS of the second)
'SDP3 --- TG2
If (Cells(i, "Y").Value = "N/A" Or Cells(i, "L").Value = "N/A") Then
Cells(i, "X").Value = "N/A"
Else
If (Cells(i, "Y").Value < 0) Then
Cells(i, "X").Value = 0
Else
Cells(i, "X").Value = Cells(i, "Y").Value * Cells(i, "L").Value
End If
End If
'SDP3 --- PTE
If (Cells(i, "AB").Value = "N/A" Or Cells(i, "P").Value = "N/A") Then
Cells(i, "AA").Value = "N/A"
Else
If (Cells(i, "AB").Value < 0) Then
Cells(i, "AA").Value = 0
Else
Cells(i, "AA").Value = Cells(i, "AB").Value * Cells(i, "P").Value
End If
End If
'TG2 -- PTE
If (Cells(i, "AE").Value = "N/A" Or Cells(i, "P").Value = "N/A") Then
Cells(i, "AD").Value = "N/A"
Else
If (Cells(i, "AE").Value < 0) Then
Cells(i, "AD").Value = 0
Else
Cells(i, "AD").Value = Cells(i, "AE").Value * Cells(i, "P").Value
End If
End If
' indicators Y,AB,AE - > Z, AC , AF
If (Cells(i, "Y").Value = "N/A") Then
Cells(i, "Z").Value = "N/A"
Else
If (Cells(i, "Y").Value < 0) Then
Cells(i, "Z").Value = Chr(226)
Cells(i, "Z").Font.Name = "Wingdings"
Cells(i, "Z").Font.Color = vbRed
ElseIf (Cells(i, "Y").Value > 0) Then
Cells(i, "Z").Value = Chr(225)
Cells(i, "Z").Font.Name = "Wingdings"
Cells(i, "Z").Font.Color = vbGreen
Else
Cells(i, "Z").Value = "-"
End If
End If
If (Cells(i, "AB").Value = "N/A") Then
Cells(i, "AC").Value = "N/A"
Else
If (Cells(i, "AB").Value < 0) Then
Cells(i, "AC").Value = Chr(226)
Cells(i, "AC").Font.Name = "Wingdings"
Cells(i, "AC").Font.Color = vbRed
ElseIf (Cells(i, "AB").Value > 0) Then
Cells(i, "AC").Value = Chr(225)
Cells(i, "AC").Font.Name = "Wingdings"
Cells(i, "AC").Font.Color = vbGreen
Else
Cells(i, "AC").Value = "-"
End If
End If
If (Cells(i, "AE").Value = "N/A") Then
Cells(i, "AF").Value = "N/A"
Else
If (Cells(i, "AE").Value < 0) Then
Cells(i, "AF").Value = Chr(226)
Cells(i, "AF").Font.Name = "Wingdings"
Cells(i, "AF").Font.Color = vbRed
ElseIf (Cells(i, "AE").Value > 0) Then
Cells(i, "AF").Value = Chr(225)
Cells(i, "AF").Font.Name = "Wingdings"
Cells(i, "AF").Font.Color = vbGreen
Else
Cells(i, "AF").Value = "-"
End If
End If
Next
' format the columns
Columns("Y:Y").Select
Selection.NumberFormat = "0.00%"
Columns("AB:AB").Select
Selection.NumberFormat = "0.00%"
Columns("AE:AE").Select
Selection.NumberFormat = "0.00%"
ActiveSheet.Range("A5:AF" & lrow).Copy
ThisWorkbook.Worksheets("final").Activate
Application.Wait (Now + TimeValue("0:00:01"))
lrowFinal = Cells(Rows.Count, "C").End(xlUp).row
If lrowFinal < 4 Then
lrowFinal = 4
End If
ThisWorkbook.Sheets("final").Range("C3:AH" & lrowFinal).ClearContents
ThisWorkbook.Sheets("final").Range("C4").PasteSpecial (Excel.XlPasteType.xlPasteAll)
'ActiveSheet.PasteSpecial Paste:=xlPasteValues
'PasteAsLocalFormula
Application.CutCopyMode = False
With ActiveSheet
.AutoFilterMode = False
.Range("C4").CurrentRegion.AutoFilter
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
the error happens a few lines at the end at:
ThisWorkbook.Sheets("final").Range("C4").PasteSpecial (Excel.XlPasteType.xlPasteAll)
what did I do wrong, I tried many fixes but none worked
EDIT:
I changed the copying code to the following but I am still getting the error:
ThisWorkbook.Sheets("final").Activate
Application.Wait (Now + TimeValue("0:00:01"))
lrowFinal = Cells(Rows.Count, "C").End(xlUp).row
If lrowFinal < 4 Then
lrowFinal = 4
End If
ActiveSheet.Range("C3:AH" & lrowFinal).ClearContents
Sheets("temporary").Activate
ActiveSheet.Range("A5:AF" & lrow).Copy
ThisWorkbook.Worksheets("final").Activate
ActiveSheet.Range("C4").PasteSpecial xlPasteAll
Related
I am very much a novice with VBA but i have managed to write code that runs. My issue is that when i run it with many thousands of rows it basically grinds to a halt and nothing happens for well over an hour (when i run for 150K rows). On top of my code i have added:
I have also attempted to avoid using .select whenever i could. Is there anything that i'm missing or is there a way that i could improve my code? Since i've pasted various code i'm sure i've done something wrong.
Sub Eng11()
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Last As Long
Dim i As Long
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastrow As Long
Dim sPath As String, sFile As String
Dim wb As Workbook
Dim x As Long
Dim ws As Worksheet
sPath = "C:\Users\nascd\Downloads\Pronto Master\"
sFile = sPath & Sheets("Sheet 1").Range("J2").Text
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sFile)
Set sht1 = wkb1.Sheets("Data Table")
Set sht2 = wkb2.Sheets("Sheet1")
Set ws = sht2
Last = Cells(Rows.Count, "AX").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "T" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "AY").Text) = "1" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "AY").Text) = "2" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
End Sub
I think that this is as condensed as I can make it. Certainly some logic magician could come in and make this shorter but I think they might not be able to fit the if logic onto a single line!
This will only loop once, which should have been your biggest obstacle in terms of time to run. I made sure to specify that you're searching in sht2, removed some unused variables, and made sure to reset your application settings at the end of the sub. Other than that, the only thing I really did was combine your if statements as best as I could and put them into one loop.
Sub Eng11()
With Application
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Dim sht1 As Worksheet
Set sht1 = ThisWorkbook.Sheets("Data Table")
Dim sPath As String
sPath = "C:\Users\nascd\Downloads\Pronto Master\"
Dim sFile As String
sFile = sPath & sht1.Range("J2").Value2
Dim sht2 As Worksheet
Set sht2 = Workbooks.Open(sFile).Sheets(1)
Dim lastRow As Long
lastRow = sht2.Cells(Rows.count, "AX").End(xlUp).row
Dim i As Long
For i = 2 To lastRow
With sht2
If .Cells(i, "AZ").Value2 = .Cells(i, "AB").Value2 And _
.Cells(i, "BA").Value2 = .Cells(i, "AC").Value2 Then
If .Cells(i, "AY").Value2 = "C" And _
(.Cells(i, "AA").Value2 = "E" Or .Cells(i, "AA").Value2 = "T") Then
.Cells(i, "AX").Value2 = .Cells(i, "Z").Value2
.Cells(i, "AY").Value2 = .Cells(i, "AA").Value2
.Cells(i, "AZ").Value2 = .Cells(i, "AB").Value2
.Cells(i, "BA").Value2 = .Cells(i, "AC").Value2
End If
ElseIf .Cells(i, "AA").Value2 = "E" And _
(.Cells(i, "AY").Value2 = 2 Or .Cells(i, "AY").Value2 = 1) Then
.Cells(i, "AX").Value2 = .Cells(i, "Z").Value2
.Cells(i, "AY").Value2 = .Cells(i, "AA").Value2
.Cells(i, "AZ").Value2 = .Cells(i, "AB").Value2
.Cells(i, "BA").Value2 = .Cells(i, "AC").Value2
End If
End With
Next i
With Application
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub Eng11()
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Last As Long
Dim i As Long
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastrow As Long
Dim sPath As String, sFile As String
Dim wb As Workbook
Dim x As Long
Dim ws As Worksheet
sPath = "C:\Users\nascd\Downloads\Pronto Master\"
sFile = sPath & Sheets("Sheet 1").Range("J2").Text
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sFile)
Set sht1 = wkb1.Sheets("Data Table")
Set sht2 = wkb2.Sheets("Sheet1")
Set ws = sht2
Last = Cells(Rows.Count, "AX").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "T" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
If (Cells(i, "AY").Text) = "1" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
If (Cells(i, "AY").Text) = "2" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
End Sub
Can you pardon to let me the know the difference of last two Ifs as the function is same for both ifs condition.
I have the following IF Statement:
If Cells(i, 4).NumberFormat <> "0.0%" Or IsEmpty(Cells(i, 4)) Or Cells(i, 4).Value2 = "" Then
Cells(i, 4).NumberFormat = "0.0%"
Cells(i, 4).Value = Cells(i, 4).Value / 100
'Else
'Cells(i, 4).Value = Cells(i, 4).Value
'Cells(i, 4).Value = Cells(i, 4).Value
End If
When I launch the code, it runs for every cell that has data in it but,
if the cell is empty it does not run and gives me an error saying "Type Mismatch"
Here is the whole code:
Public Sub SortMyData()
Dim i As Integer
Dim N_Values As Integer
N_Values = Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To N_Values
'Cells(i, 3).NumberFormat = "0"
If Cells(i, 2).NumberFormat <> "0.0%" Then
Cells(i, 2).NumberFormat = "0.0%"
Cells(i, 2).Value = Cells(i, 2).Value / 100
'Else
'Cells(i, 2).Value = Cells(i, 2).Value
'Cells(i, 3).Value = Cells(i, 3).Value
End If
If (Cells(i, 3).Value) > 1000000 Then
Cells(i, 3).Value = Cells(i, 3).Value / 1000000 & "Mb"
Cells(i, 3).HorizontalAlignment = xlRight
ElseIf (Cells(i, 3).Value) > 1000 Then
Cells(i, 3).Value = Cells(i, 3).Value / 1000 & "kb"
Cells(i, 3).HorizontalAlignment = xlRight
ElseIf Cells(i, 3).Value = Null Or Cells(i, 3).Text = Null Or Cells(i, 3).Value = "" Or Cells(i, 3).Text = "" Then
Cells(i, 3).Value = 0
Cells(i, 3).HorizontalAlignment = xlRight
End If
If Cells(i, 4).NumberFormat <> "0.0%" Or IsEmpty(Cells(i, 4)) Or Cells(i, 4).Value2 = "" Then
Cells(i, 4).NumberFormat = "0.0%"
Cells(i, 4).Value = Cells(i, 4).Value / 100
'Else
'Cells(i, 4).Value = Cells(i, 4).Value
'Cells(i, 4).Value = Cells(i, 4).Value
End If
Next i
End Sub
I added some With for better readability and tested the values before dividing them :
Public Sub SortMyData()
Dim wS As Worksheet
Dim i As Long
Dim N_Values As Long
Set wS = ThisWorkbook.Sheets("Sheet1")
N_Values = wS.Cells(wS.Rows.Count, 2).End(xlUp).Row
With wS
For i = 6 To N_Values
With .Cells(i, 2)
If .NumberFormat <> "0.0%" Then
.NumberFormat = "0.0%"
If .Value2 <> vbNullString And IsNumeric(.Value2) Then .Value = .Value / 100
Else
End If
End With
With .Cells(i, 3)
.HorizontalAlignment = xlRight
Select Case .Value
Case Is > 1000000
.Value = .Value / 1000000 & "Mb"
Case Is > 1000
.Value = .Value / 1000 & "kb"
Case Is > 1
.Value = .Value & "b"
Case Else
.Value = 0
End Select
' If (.Value) > 1000000 Then
' .Value = .Value / 1000000 & "Mb"
' ElseIf (.Value) > 1000 Then
' .Value = .Value / 1000 & "kb"
' ElseIf .Value = Null Or .Text = Null Or .Value = "" Or .Text = "" Then
' .Value = 0
' End If
End With
With .Cells(i, 4)
If .NumberFormat <> "0.0%" Then
.NumberFormat = "0.0%"
If .Value2 <> vbNullString And IsNumeric(.Value2) Then .Value = .Value / 100
Else
End If
End With
Next i
End With
End Sub
The following script selects a range of data on one sheet and transfers the selection to another sheet.
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.Save
End If
Next i
I would now like to introduce a script which will replace the row of data on the target sheet if the value in column A already exists, but i'm not sure how to achieve this, any help is much appreciated.
Thank you in advance.
Public Function IsIn(li, Val) As Boolean
IsIn = False
Dim c
For Each c In li
If c = Val Then
IsIn = True
Exit Function
End If
Next c
End Function
dim a: a= range(destWB.sheet(whatever)..range("A1"),destWB.Range("A" & destWB.sheet(whatever).Rows.Count).End(xlUp)).value
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
if isin(a, Cells(i, 1) ) then
do whatever you want
else
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.save
End If
End If
Next i
I suggest using a Dictionary-Object which is most likely a Hash-Map. The advantage is that you can use the built in method Dictionary.Exists(Key) to check if the Dictionary already holds the specified value (Key).
Also you should not save the Workbook in every step of the iteration. It would be better (and faster) to only save the workbook after completing the copying of your whole data.
Additionally your If-Tests after copy-paste are not neccessary, because you are already checking for Cells(i,1)<>"" before copying so you don't have to check this again as it does not change.
The following code shows how to get your desired result:
Set dict = CreateObject("Scripting.Dictionary")
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
If dict.Exists(Cells(i,1).Value) Then
'value already exists -> update row number
dict.Item(Cells(i,1).Value)=i
Else
'save value of column A and row number in dictionary
dict.Add Cells(i,1).Value, i
End If
Cells(i, 22).Value = "Yes"
Cells(i, 23).Value = Now
Cells(i, 24).Value = Environ("UserName")
End If
Next i
'finally copy over your data (only unique values)
For Each i In dict.Items
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
Next i
The first section is where I am copying the data from and the second section is where I am pasting the data to. Multiple worksheets will be added to the workbook ( tech collect) so when i run the code it should copy all info from "tech collect" to "tech database"
Sub Test()
'
' Test Macro
' test
'
' Keyboard Shortcut: Ctrl+a
'
Sheets("Technician Collection").Select
Range("B3").Select
Sheets("Tech Collection Database").Select
Range("B6").Select
Sheets("Technician Collection").Select
xb3 = (ActiveCell.Value)
xb4 = (ActiveCell.Offset(1, 0).Value)
xb5 = (ActiveCell.Offset(2, 0).Value)
xb6 = (ActiveCell.Offset(3, 0).Value)
xb7 = (ActiveCell.Offset(4, 0).Value)
xb8 = (ActiveCell.Offset(5, 0).Value)
xb9 = (ActiveCell.Offset(6, 0).Value)
xb10 = (ActiveCell.Offset(7, 0).Value)
xb11 = (ActiveCell.Offset(8, 0).Value)
xb12 = (ActiveCell.Offset(9, 0).Value)
xb15 = (ActiveCell.Offset(12, 0).Value)
xb16 = (ActiveCell.Offset(13, 0).Value)
xb17 = (ActiveCell.Offset(14, 0).Value)
xb18 = (ActiveCell.Offset(15, 0).Value)
xb19 = (ActiveCell.Offset(16, 0).Value)
xb20 = (ActiveCell.Offset(17, 0).Value)
xb21 = (ActiveCell.Offset(18, 0).Value)
xb22 = (ActiveCell.Offset(19, 0).Value)
xb24 = (ActiveCell.Offset(21, 0).Value)
xc24 = (ActiveCell.Offset(21, 1).Value)
xd24 = (ActiveCell.Offset(21, 2).Value)
xe24 = (ActiveCell.Offset(21, 3).Value)
xb25 = (ActiveCell.Offset(22, 0).Value)
xb26 = (ActiveCell.Offset(23, 0).Value)
xc26 = (ActiveCell.Offset(23, 1).Value)
xd26 = (ActiveCell.Offset(23, 2).Value)
xe26 = (ActiveCell.Offset(23, 3).Value)
xb27 = (ActiveCell.Offset(24, 0).Value)
xc27 = (ActiveCell.Offset(24, 1).Value)
xd27 = (ActiveCell.Offset(24, 2).Value)
xe27 = (ActiveCell.Offset(24, 3).Value)
xb28 = (ActiveCell.Offset(25, 0).Value)
xc28 = (ActiveCell.Offset(25, 1).Value)
xd28 = (ActiveCell.Offset(25, 2).Value)
xe28 = (ActiveCell.Offset(25, 3).Value)
xb30 = (ActiveCell.Offset(27, 0).Value)
xc30 = (ActiveCell.Offset(27, 1).Value)
xd30 = (ActiveCell.Offset(27, 2).Value)
xe30 = (ActiveCell.Offset(27, 3).Value)
xb32 = (ActiveCell.Offset(29, 0).Value)
xb34 = (ActiveCell.Offset(31, 0).Value)
xb36 = (ActiveCell.Offset(33, 0).Value)
xb40 = (ActiveCell.Offset(37, 0).Value)
xb41 = (ActiveCell.Offset(38, 0).Value)
xb42 = (ActiveCell.Offset(39, 0).Value)
xb43 = (ActiveCell.Offset(40, 0).Value)
xb44 = (ActiveCell.Offset(41, 0).Value)
xb45 = (ActiveCell.Offset(42, 0).Value)
xb46 = (ActiveCell.Offset(43, 0).Value)
xb47 = (ActiveCell.Offset(44, 0).Value)
xb48 = (ActiveCell.Offset(45, 0).Value)
Sheets("Tech Collection Database").Select
ActiveCell.Value = xb3
ActiveCell.Offset(0, 1).Value = xb4
ActiveCell.Offset(0, 2).Value = xb5
ActiveCell.Offset(0, 3).Value = xb6
ActiveCell.Offset(0, 4).Value = xb7
ActiveCell.Offset(0, 5).Value = xb8
ActiveCell.Offset(0, 6).Value = xb9
ActiveCell.Offset(0, 7).Value = xb10
ActiveCell.Offset(0, 8).Value = xb11
ActiveCell.Offset(0, 9).Value = xb12
ActiveCell.Offset(0, 10).Value = xb15
ActiveCell.Offset(0, 11).Value = xb16
ActiveCell.Offset(0, 12).Value = xb17
ActiveCell.Offset(0, 13).Value = xb18
ActiveCell.Offset(0, 14).Value = xb19
ActiveCell.Offset(0, 15).Value = xb20
ActiveCell.Offset(0, 16).Value = xb21
ActiveCell.Offset(0, 17).Value = xb22
ActiveCell.Offset(0, 18).Value = xb24
ActiveCell.Offset(0, 19).Value = xc24
ActiveCell.Offset(0, 20).Value = xd24
ActiveCell.Offset(0, 21).Value = xe24
ActiveCell.Offset(0, 22).Value = xb25
ActiveCell.Offset(0, 23).Value = xb26
ActiveCell.Offset(0, 24).Value = xc26
ActiveCell.Offset(0, 25).Value = xd26
ActiveCell.Offset(0, 26).Value = xe26
ActiveCell.Offset(0, 27).Value = xb27
ActiveCell.Offset(0, 28).Value = xc27
ActiveCell.Offset(0, 29).Value = xd27
ActiveCell.Offset(0, 30).Value = xe27
ActiveCell.Offset(0, 31).Value = xb28
ActiveCell.Offset(0, 32).Value = xc28
ActiveCell.Offset(0, 33).Value = xd28
ActiveCell.Offset(0, 34).Value = xe28
ActiveCell.Offset(0, 35).Value = xb30
ActiveCell.Offset(0, 36).Value = xc30
ActiveCell.Offset(0, 37).Value = xd30
ActiveCell.Offset(0, 38).Value = xe30
ActiveCell.Offset(0, 39).Value = xb32
ActiveCell.Offset(0, 40).Value = xb34
ActiveCell.Offset(0, 41).Value = xb36
ActiveCell.Offset(0, 42).Value = xb40
ActiveCell.Offset(0, 43).Value = xb41
ActiveCell.Offset(0, 44).Value = xb42
ActiveCell.Offset(0, 45).Value = xb43
ActiveCell.Offset(0, 46).Value = xb44
ActiveCell.Offset(0, 47).Value = xb45
ActiveCell.Offset(0, 48).Value = xb46
ActiveCell.Offset(0, 49).Value = xb47
ActiveCell.Offset(0, 50).Value = xb48
End Sub
The first section is where I am copying the data from and the second section is where I am pasting the data to
This is what I have used to step though every sheet except for one:
For Each Sh In MyWkBk.Sheets
If Sh.Name <> "Reference" Then
'....
'Your Code Here
'....
End If
Next
I'm breaking my head over this one and I hope someone can help. I have a procedure that adds a new worksheet into an Excel workbook and adds basic information of this worksheet into an overview in another worksheet (same workbook). It all works fine as it should, but unfortunately with one exception. There is one cell that should have the value of a cell in the newly created Worksheet. I've used this line for it:
c.Offset(0, 27).Value = "=" & Left(AccName.Value, 20) & "!N16"
Here the "Left(AccName.value,20)" equals the worksheet name. Unfortunately here the code opens a dialog window where I can open a file. I have no idea why and thus no idea how I can fix this. Does anybody here have any idea?
Edit: Here's the entire sub:
Sub FillBestandsübersicht()
Dim c As Range
Dim i As Integer
i = 3
'Find next empty row
Set c = Sheets("Bestandsübersicht").Range("A3")
Do Until c.Value = ""
Set c = c.Offset(1, 0)
i = i + 1
Loop
'Fill Bestandsübersicht
c.Value = AccName.Value
c.Offset(0, 1).Value = ProgRef.Value
c.Offset(0, 2).Value = QuoteNr.Value
c.Offset(0, 3).Value = PolicyNr.Value
If LdrY.Value = True Or LocY.Value = False Then c.Offset(0, 4).Value = "n.a."
c.Offset(0, 5).Value = ddUnderwriters.Value
c.Offset(0, 6).Value = IncDate.Value
c.Offset(0, 7).Value = ExpDate.Value
If LdrY.Value = True Then
c.Offset(0, 8).Value = "Lead"
Else
c.Offset(0, 8).Value = "Follow"
End If
c.Offset(0, 10).Value = PMNPL.Value
If LdrY.Value = True And LocY.Value = True Then
c.Offset(0, 11).Value = AmountLoc.Value
Else
c.Offset(0, 11).Value = 0
End If
If CoiY.Value = True Then
c.Offset(0, 12).Value = AmountCOI.Value
Else
c.Offset(0, 12).Value = 0
End If
c.Offset(0, 14).Value = "n"
c.Offset(0, 15).Value = "n"
If DocY.Value = False Then c.Offset(0, 16).Value = "x" Else c.Offset(0, 16).Value = "n"
If LdrY.Value = False Or LocY.Value = False Or CoiY.Value = False Then _
c.Offset(0, 17).Value = "x" Else c.Offset(0, 17).Value = "n"
If FacY.Value = False Then c.Offset(0, 18).Value = "x" Else c.Offset(0, 18).Value = "n"
If LdrY.Value = True Or LocY.Value = False Then c.Offset(0, 19).Value = "x" Else c.Offset(0, 19).Value = "n"
If LdrY.Value = False Or LocY.Value = False Then c.Offset(0, 20).Value = "x" Else c.Offset(0, 20).Value = "n"
c.Offset(0, 21).Value = "n"
c.Offset(0, 26).Value = Left(AccName.Value, 20)
c.Offset(0, 27).Value= "=" & Left(AccName.Value, 20) & "!N16"
'Sort Bestandsübersicht
Range("A3:AB10000").Sort key1:=Range("A3:A10000"), order1:=xlAscending, Header:=xlNo
'AutoFit rows
Sheets("Bestandsübersicht").Rows("3:" & i).EntireRow.autofit
End Sub
I think there is no sheet within your workbook which name equals to result of this function/calculation: Left(AccName.Value, 20)