Sub OK_y_run()
Dim xlast_Row As Long
Dim xNew_Row As Long
Dim i As Long
Sheets("Data").Activate
xlast_Row = Range("A1").SpecialCells(xlLastCell).Row
If xlast_Row < 2 Then
MsgBox ("No data in PAS Spreadsheet - run cancelled.")
Exit Sub
End If
Sheets("Actual").Activate
Range("A4:H50000").Select
Selection.ClearContents
Sheets("Data").Activate
If Sheets("Actual").UsedRange.Rows.Count < 0 Then MsgBox ("Error") ' Force Excel to recalculate the last row.
xNew_Row = Sheets("Actual").Range("A:A").SpecialCells(xlLastCell).Row
For i = 3 To xlast_Row
If Cells(i, 8) = "IMMS" Then
xNew_Row = xNew_Row + 1
Sheets("Actual").Range("A" & xNew_Row & ":H" & xNew_Row) = _
Array(Cells(i, 5), _
"", _
Cells(i, 6), _
Cells(i, 3), _
Cells(i, 7), _
"", _
Cells(i, 2), _
Cells(i, 1))
End If
Next
Example-1---Copying-Cells.xlsm
xNew_Row = Sheets("Actual").Range("A:A").SpecialCells(xlLastCell).Row
With Sheets("Actual")
xNew_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
xNew_Row = LastRow(Sheets("Actual"))
Option Explicit
Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
Sub OK_y_run()
Dim xlast_Row As Long
Dim xNew_Row As Long
Dim i As Long, x As Long, counter As Long
Dim ws As Worksheet
Dim arr As Variant
Dim MyDictionary As Scripting.Dictionary
Set MyDictionary = New Scripting.Dictionary
MyDictionary.CompareMode = vbBinaryCompare
Set ws = Sheets("Names")
xlast_Row = LastRow(ws)
arr = ws.Range("A1:B" & xlast_Row).Value
For counter = 1 To UBound(arr, 1)
If Not MyDictionary.Exists(arr(counter, 1)) Then MyDictionary.Add arr(counter, 1), arr(counter, 2)
Next
Set ws = Sheets("Data")
xlast_Row = LastRow(ws)
arr = ws.Range("A2:N" & xlast_Row).Value
If xlast_Row < 2 Then
MsgBox ("No data to run against")
Exit Sub
End If
Set ws = Sheets("Actual")
ws.Range("A4:H50000").ClearContents
Dim OutArr()
x = 0
ReDim OutArr(1 To 8, 1 To 1)
For i = 1 To UBound(arr)
If arr(i, 8) = "IMMS" Then
x = x + 1
ReDim Preserve OutArr(1 To 8, 1 To x)
OutArr(1, x) = arr(i, 5)
OutArr(2, x) = MyDictionary.Item(arr(i, 6))
OutArr(3, x) = arr(i, 6)
OutArr(4, x) = arr(i, 3)
OutArr(5, x) = arr(i, 7)
OutArr(6, x) = ""
OutArr(7, x) = arr(i, 2)
OutArr(8, x) = arr(i, 1)
End If
Next
ws.Range("A4:H" & x).Value = Application.Transpose(OutArr)
End Sub
ws.Range("A4:H" & x).Value = Application.Transpose(OutArr)
needs to bews.Range("A4:H" & x + 3).Value = Application.Transpose(OutArr)
Option Explicit
Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
Sub OK_y_run()
Dim xlast_Row As Long
Dim xNew_Row As Long
Dim i As Long, x As Long, counter As Long
Dim ws As Worksheet
Dim arr As Variant
Dim MyDictionary As Scripting.Dictionary
Set MyDictionary = New Scripting.Dictionary
MyDictionary.CompareMode = vbBinaryCompare
Set ws = Sheets("Names")
xlast_Row = LastRow(ws)
arr = ws.Range("A1:B" & xlast_Row).Value
For counter = 1 To UBound(arr, 1)
If Not MyDictionary.Exists(arr(counter, 1)) Then MyDictionary.Add arr(counter, 1), arr(counter, 2)
Next
Set ws = Sheets("Data")
xlast_Row = LastRow(ws)
arr = ws.Range("A2:N" & xlast_Row).Value
If xlast_Row < 2 Then
MsgBox ("No data to run against")
Exit Sub
End If
Set ws = Sheets("Actual")
ws.Range("A4:H50000").ClearContents
Dim OutArr()
x = 0
ReDim OutArr(1 To 8, 1 To 1)
For i = 1 To UBound(arr)
If arr(i, 8) = "IMMS" Then
x = x + 1
ReDim Preserve OutArr(1 To 8, 1 To x)
OutArr(1, x) = Format(arr(i, 5), "dd-mmm-yyyy")
OutArr(2, x) = MyDictionary.Item(arr(i, 6))
OutArr(3, x) = arr(i, 6)
OutArr(4, x) = arr(i, 3)
OutArr(5, x) = arr(i, 7)
OutArr(6, x) = ""
OutArr(7, x) = arr(i, 2)
OutArr(8, x) = arr(i, 1)
End If
Next
ws.Range("A4:H" & x + 3).Value = Application.Transpose(OutArr)
End Sub
Example-1---Copying-Cells.xlsm
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.