I am getting error while pasting the data . I do activate the workbook and sheet and like fully qualified. but not sure what I am missing here.
I am copying the data from 1 workbook to another. Sometimes it is working fine and sometimes I am getting the error. When the data is not copied , row number is set to zero. I am not sure why the data is not copied.
Sub PasteFormattedRange(rgFrom As Range, rgTo As Range)
Dim S As String
Dim rgStart As Range
Dim i As Long, CF_Format As Long
Dim SaveDisplayAlerts As Boolean, SaveScreenUpdating As Boolean
Dim HTMLInClipBoard As Boolean
Dim Handle As Long, Ptr As Long, FileName As String
Dim Rownum, Rownum1, Rownum2, Rownum3 As Integer
Application.DisplayAlerts = False
With Workbooks("Template.xlsm").Worksheets("Sheet1").Columns(1)
Set Rowfind = .Find(What:="CASH FLOW", LookIn:=xlValues, lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Rowfind Is Nothing Then
Rownum = 0
Else
Rownum = Rowfind.Row
End If
Set Rowfind = .Find(What:="VARIANCE $000'S", LookIn:=xlValues, lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Rowfind Is Nothing Then
Rownum1 = 0
Else
Rownum1 = Rowfind.Row + 1
End If
End With
Set rgStart = Selection
rgFrom.Copy
DoEvents
'Enumerate the clipboard formats
If OpenClipboard(0) Then
CF_Format = EnumClipboardFormats(0&)
Do While CF_Format <> 0
S = String(255, vbNullChar)
i = GetClipboardFormatName(CF_Format, S, 255)
S = Left(S, i)
HTMLInClipBoard = InStr(1, S, "HTML Format", vbTextCompare) > 0
If HTMLInClipBoard Then
Application.CutCopyMode = False
Application.GoTo rgTo
DoEvents
ActiveSheet.PasteSpecial Format:="HTML"
Application.GoTo rgStart
Exit Do
End If
CF_Format = EnumClipboardFormats(CF_Format)
Loop
CloseClipboard
End If
With Newsheet.Columns(1)
Set Rowfind = .Find(What:="CASH FLOW", LookIn:=xlValues, lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Rowfind Is Nothing Then
Rownum2 = 0
Else
Rownum2 = Rowfind.Row
End If
Set Rowfind = .Find(What:="VARIANCE $000'S", LookIn:=xlValues, lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Rowfind Is Nothing Then
Rownum3 = 0
Else
Rownum3 = Rowfind.Row + 1
End If
End With
Workbooks("Template.xlsm").Worksheets("Sheet1").Range("B" & Rownum & ":BL" & Rownum).Copy
Workbooks(newBook).Activate
Newsheet.Activate
Newsheet.Range("B" & Rownum2 & ":BL" & Rownum2).PasteSpecial Paste:=xlPasteValues
Newsheet.Range("B" & Rownum2 & ":BL" & Rownum2).PasteSpecial Paste:=xlPasteFormats
Workbooks("Template.xlsm").Worksheets("Sheet1").Range("B" & Rownum1 & ":BL" & Rownum1).Copy
Workbooks(newBook).Activate
Newsheet.Activate
Newsheet.Range("B" & Rownum3 & ":BL" & Rownum3).PasteSpecial Paste:=xlPasteValues
Newsheet.Range("B" & Rownum3 & ":BL" & Rownum3).PasteSpecial Paste:=xlPasteFormats
Related
I want to loop or find multiple value in another sheets. My code doesn't work even after I do..loop the code.
For i = 1 To lastrowBAU
Worksheets(fname).Range("A1:A" & lastrowsheet).Select
Do Until Cell Is Nothing
Set Cell = Selection.find(What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False)
If Not Cell Is Nothing Then
Cell.Activate
ActiveCell.Copy
ActiveCell.Insert Shift:=xlShiftDown
ActiveCell.Offset(1, 0).Select
Selection.Replace What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, _
replacement:=ThisWorkbook.Worksheets("BAU").Range("B" & i).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Set Cell = Worksheets(fname).Range("A1:A" & lastrowsheet).FindNext(Cell)
End If
Loop
Next i
You need to set the cell before entering the loop
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
however you also need to avoid an endless loop by checking if the search has returned to the first one found.
Option Explicit
Sub macro1()
Dim ws As Worksheet, wsBAU As Worksheet
Dim cell As Range, rngSrc As Range
Dim fname As String, lastrow As Long, lastrowBAU As Long
Dim i As Long, n As Long, first As String
Dim sA As String, sB As String
fname = "Sheet1"
With ThisWorkbook
Set ws = .Sheets(fname)
Set wsBAU = .Sheets("BAU")
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
With wsBAU
lastrowBAU = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
' search and replace
Application.ScreenUpdating = False
For i = 1 To lastrowBAU
sA = wsBAU.Cells(i, "A")
sB = wsBAU.Cells(i, "B")
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
first = cell.Address
Do
' insert cell above
cell.Insert xlDown
cell.Offset(-1).Value2 = cell.Value2
cell.Value2 = Replace(cell.Value2, sA, sB)
' expand search range
n = n + 1
Set rngSrc = ws.Range("A1:A" & lastrow + n)
' find next
Set cell = rngSrc.FindNext(cell)
Loop While cell.Address <> first
End If
Next
Application.ScreenUpdating = True
MsgBox n & " replacements", vbInformation
End Sub
When trying to run the below code, a compile error of for without next or next without for is experienced. The error message keeps appearing in loops (once a for without next error, the next time a next without for error), making it difficult to spot where the error is.
How to check if an "end if" is missing or if there is an indentation error?
Please help!
Sub DataCleaning()
Dim ws As Worksheet
Dim myValue As Variant
Dim StringToFind As String
Dim f, cell, cell1 As Range
Dim LastCol, LastCol1 As Long
Dim i, j, k, l As Integer
Application.DisplayAlerts = False 'Optional
For Each ws In Worksheets
Select Case ws.Name
'Include sheet names to keep on next line (with comma between)
Case "VIE", "CA", "UK", "EU", "CHN", "JP", "AU", "NZ", "KR", "PH", "TH", "ID"
ws.Cells.ClearFormats
Case Else
ws.Delete
End Select
Next ws
Application.DisplayAlerts = True
StringToFind = Application.InputBox("Input Batch Number:")
For Each ws In Worksheets
'myValue = InputBox("Input Batch Number:", ws, 1)
ws.Activate
ActiveSheet.Rows(4).Select
Set cell = Selection.Find(what:="Batch " & StringToFind, After:=ActiveCell, _
LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
MsgBox "No Order"
Else
cell.Offset(0, -1).Select
ColumnLetter = Split(Cells(1, ActiveCell.Column).Address, "$")(1)
Range(Columns("B"), Columns(ColumnLetter)).EntireColumn.Delete
LastCol = Cells(5, Columns.Count).End(xlToLeft).Column
ws.Activate
ActiveSheet.Rows(5).Select
Set cell1 = Selection.Find(what:="<", After:=ActiveCell, _
LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
cell1.Select
ColumnLetter1 = Split(Cells(1, ActiveCell.Column).Address, "$")(1)
Range(Cells(1, ColumnLetter1), Cells(1, LastCol)).EntireColumn.Delete
Rows(1).EntireRow.Delete
Range("A1") = "Batch"
Range("A2") = "City"
Range("A3") = "Number"
Range("A4") = "Shipment"
LastCol1 = Cells(4, Columns.Count).End(xlToLeft).Column
With Range("B1")
For j = 2 To LastCol1
Cells(1, j) = StringToFind
Next j
End With
With Range("B2")
For k = 2 To LastCol1
Cells(2, k) = ws.Name
Next k
End With
With Range("B3")
For l = 2 To LastCol1
Cells(3, l) = ""
Next l
End With
Cells(4, LastCol1 + 1) = "Price"
i = 1
Do While Not IsEmpty(Cells(i, 1))
SKUColumn = Cells(i, 1)
If SKUColumn Like "2018" Then
ws.Rows([i]).EntireRow.Delete
Deleted = True
ElseIf SKUColumn Like "2020" Then
ws.Rows([i]).EntireRow.Delete
Deleted = True
ElseIf SKUColumn Like "Accessories" Then
ws.Rows([i]).EntireRow.Delete
Deleted = True
End If
i = i + 1
Loop
Application.ScreenUpdating = True
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\xxx\Desktop\" & ws.Name & ".csv" _
, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=True
Application.ScreenUpdating = False
Next ws
End If 'this line should be in front of `Next ws`
The code I have, works, but it is slow and I want to avoid using select.
I have tried something in the line of the following:
Sub PopulateBlastEvents()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Arng As Range
Dim NotF As String
Dim Found As Range
Application.ScreenUpdating = False
NotF = "NO INFO"
BSStep = 1
Set Rrng = Sheets("Blast List").Range("A2:A45")
Set Srng = Sheets("Blast List").Range("E1:R1")
For Each cell In Rrng
If cell <> "" Then
For Each cell2 In Srng
If cell2 <> "" Then
On Error Resume Next
SI = cell.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = Sheets(CStr(BlNumber))
Set wsl = Sheets("Blast List")
With wsfr.Range("A:A")
Set Found = Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Found Is Nothing Then
With wsl.Range("A:A")
Set Found1 = Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1)
Found1.Value = NotF
End With
Else
With wsl.Range("A:A")
Set Found1 = Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1)
Found1.Value = Found.Value
End With
End If
End With
End If
Next cell2
BSStep = BSStep + 1
End If
Next cell
Set Arng = ThisWorkbook.Worksheets("Blast List").Range("E3:X3").End(xlDown).Select
Application.ScreenUpdating = True
Columns("A:S").EntireColumn.AutoFit
End Sub
The code does run, but returns no value as the range value "rng" remains at NOTHING even though it is in the sheet where it is looking for the value.
Below is the current code I am using that needs to change:
Sub PopulateBlastEvents()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Rrng As Range
Dim Brng As Range
Dim Arng As Range
Dim NotF As String
Application.ScreenUpdating = False
NotF = "NO INFO"
BSStep = 1
Set Rrng = Sheets("Blast List").Range("A2:A45")
Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:R1")
For Each Brng In Rrng.Cells
If Brng <> "" Then
For Each Nrng In Srng.Cells
If Nrng <> "" Then
On Error Resume Next
SI = Nrng.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = ThisWorkbook.Worksheets(CStr(BlNumber))
Set wsl = ThisWorkbook.Worksheets("Blast List")
wsfr.Select
Range("A1").Select
Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
If Err.Description <> "" Then
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.Value = NotF
Else
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End If
Next Nrng
BSStep = BSStep + 1
End If
Next Brng
Set Arng = ThisWorkbook.Worksheets("Blast List").Range("E3:X3").End(xlDown).Select
Application.ScreenUpdating = True
Columns("A:X").EntireColumn.AutoFit
End Sub
I really want to speed up the code and all previous questions I have posted, I was informed not to or avoid using Select.
Please could someone help.
I'm trying to paste the enire row of information to the next available row but I keep getting errors about not having the Rows(lastrow +1, 1).EntireRow.Paste written correctly. Please let me know how I can perform that action correctly.
Private Sub CommandButton1_Click()
Dim myValue As String
myEmp = InputBox("Search for an employee by last name")
Range("B3").Value = myEmp
With Sheet7
Range("B:B").Select
Set Row = Selection.Find(What:=myEmp, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Row.EntireRow.Copy
End With
Worksheets("Employee Reports").Activate
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).Row
Rows(lastrow + 1, 1).EntireRow.Paste
End Sub
Private Sub Workbook_Open()
Application.EnableEvents = False
Worksheets("Sheet3").Range("A4:A20").Value = ""
End Sub
Private Sub CommandButton1_Click()
Dim myValue As String
myEmp = InputBox("Search for an employee by last name")
ActiveSheet.Range("B3").Value = myEmp
Dim lastrow As Long
lastrow = Worksheets("Employee Reports").Range("A65536").End(xlUp).Row
With Sheet7
Dim rw As Range
Set rw = .Range("B:B").Find(What:=myEmp, After:=.Range("B1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rw Is Nothing Then
rw.EntireRow.Copy Worksheets("Employee Reports").Cells(lastrow + 1, 1)
Else
MsgBox myEmp & " Not Found in Range"
End If
End With
End Sub
I would like to add the code "If Not FindRng Is Nothing Then", How can I do it? Here below there is the code that is working only when finds something!
Sub ORDER()
Dim wordToSearch As String
Dim rowToDelete As Integer
Sheets("Dashboard").Select
RowCount = Cells(Cells.Rows.Count, "W").End(xlUp).Row
For i = 1 To RowCount
Range("W" & i).Select
check_value = ActiveCell
If check_value = "Y" Or check_value = "y" Then
Sheets("Dashboard").Select
wordToSearch = Sheets("Dashboard").Range("L" & i).Value
Sheets("Order").Select
Cells.Find(What:=wordToSearch, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
rowToDelete = ActiveCell.Row
Rows(rowToDelete & ":" & rowToDelete).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Sheets("Dashboard").Select
End If
Next
End Sub
The better (and safer) way to use Find is to Set a Range to the result of the Find, and in case Find failed to "find" a match, then the result will be Range = Nothing, and you can try to trap this type of error by using If Not FindRng Is Nothing Then.
Code
Sub Macro()
Dim FindRng As Range
With Sheets("order")
Set FindRng = .Cells.Find(What:=Sheets("Dashboard").Cells(2, 4), After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not FindRng Is Nothing Then ' find was successful
FindRng.EntireRow.Delete
Else ' Find failed to find a match
MsgBox "Unable to find " & Sheets("Dashboard").Cells(2, 4), vbCritical
End If
End With
End Sub