I'm seeking assistance with copying and pasting specific cells that meet a requirement from my source data sheet to a "dashboard" sheet. I have the code below but when I run the macro it only copy and pastes the last row that meets the criteria, not all rows that meet the criteria.
For reference, I am copying 3 cells from a row in a table on the source data sheet, that may increase or decrease in size any given day, and pasting the 3 cells to the bottom of a different table in the dashboard sheet.
Any help is appreciated, thanks!
Sub CopyPaste()
Dim SourceData As Worksheet
Dim Dashboard As Worksheet
Dim searchString As String
Dim lastSourceRow As Long
Dim startSourceRow As Long
Dim lastTargetRow As Long
Dim sourceRowCounter As Long
Dim columnToEval As Long
Dim columnCounter As Long
Dim columnsToCopy As Variant
Dim columnsDestination As Variant
Set SourceData = ThisWorkbook.Worksheets("Source Data")
Set Dashboard = ThisWorkbook.Worksheets("Dashboard")
columnsToCopy = Array(7, 8, 11)
columnsDestination = Array(2, 3, 4)
searchString = "New"
startSourceRow = 3
columnToEval = 45
lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
For sourceRowCounter = startSourceRow To lastSourceRow
If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row
For columnCounter = 0 To UBound(columnsToCopy)
Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
Next columnCounter
End If
Next sourceRowCounter
SourceData.Activate
End Sub
Following from comments above:
Sub CopyPaste()
Dim SourceData As Worksheet
Dim Dashboard As Worksheet
Dim searchString As String
Dim lastSourceRow As Long
Dim startSourceRow As Long
Dim lastTargetRow As Long
Dim sourceRowCounter As Long
Dim columnToEval As Long
Dim columnCounter As Long
Dim columnsToCopy As Variant
Dim columnsDestination As Variant
Set SourceData = ThisWorkbook.Worksheets("Source Data")
Set Dashboard = ThisWorkbook.Worksheets("Dashboard")
columnsToCopy = Array(7, 8, 11)
columnsDestination = Array(2, 3, 4)
searchString = "New"
startSourceRow = 3
columnToEval = 45
lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
For sourceRowCounter = startSourceRow To lastSourceRow
If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
For columnCounter = 0 To UBound(columnsToCopy)
Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
Next columnCounter
lastTargetRow = lastTargetRow + 1 'next destination row
End If
Next sourceRowCounter
SourceData.Activate
End Sub
Related
I have a simple loop that should copy ranges form three sheets and stack them on top of each other in another sheet. I define the ranges of each of the three sheets via a cell that counts rows in the Control Sheet.
I do not get an error message, however only the range of the first sheets gets pasted. I troubleshooted already to see if the loop is running until end and indeed it does. I cannot wrap my head around why only the range from the first sheets gets pasted in the final sheet.
Sub Loop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("d")
ws_Sheet.Cells.ClearContents
counter = 1
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
lng_LastRow = Worksheets("Control").Range("E" & counter).Value + 1
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
counter = counter + 1
Next i
End Sub
The issue is
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
is the last used row (the last row that has data).
And then you use that to start pasting
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
so you overwrite the last row of data!
The next free row is lng_LastRowSheet + 1 so you should paste there:
rng_WorkRange.Copy ws_Sheet.Range("A" & (lng_LastRowSheet + 1))
You can also see that in the debug data:
a $A$1:$B$338 to A1
b $A$1:$B$91 to A338
c $A$1:$B$356 to A428
a goes from A1:B338 but you start pasting b in A338 so it overwrites the last row of a.
I gave it a test:
Created worksheet Control with data like
Then created worksheets a, b and c like
with data until row 500 so there is enough.
Then created an empty worksheet d for the output.
And used the following code. Note I have optimized it so it uses meaningful variable names, which is much easier to read, understand and debug.
Option Explicit
Public Sub CopyData()
Dim SheetNames() As Variant
SheetNames = Array("a", "b", "c")
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Worksheets("d")
wsDestination.Cells.ClearContents
Dim i As Long
For i = 0 To 2
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets(SheetNames(i))
Dim SourceLastRow As Long
SourceLastRow = ThisWorkbook.Worksheets("Control").Range("E" & i + 1).Value + 1
Dim SourceLastColumn As Long
SourceLastColumn = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Dim DestinationFreeRow As Long
DestinationFreeRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Row + 1 ' Last used row +1
Dim SourceRange As Range
Set SourceRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(SourceLastRow, SourceLastColumn))
SourceRange.Copy wsDestination.Range("A" & DestinationFreeRow)
Next i
End Sub
And I get a perfect output like:
Note that in the output I have hidden some rows so you can see eveything is there. This code perfectly does what it is supposed to.
Stack Ranges (Vertically) From Multiple Worksheets
Sub StackRanges()
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sWorksheetNames() As Variant: sWorksheetNames = VBA.Array("a", "b", "c")
' Lookup (Source Last Row)?
Dim lws As Worksheet: Set lws = wb.Worksheets("Control")
Dim llrCell As Range: Set llrCell = lws.Range("E1")
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("d")
dws.UsedRange.ClearContents
Dim dfCell As Range: Set dfCell = dws.Range("A1")
Dim sws As Worksheet
Dim srg As Range
Dim slRow As Long
Dim slColumn As Long
Dim i As Long
' Loop.
For i = 0 To UBound(sWorksheetNames)
Set sws = wb.Worksheets(sWorksheetNames(i))
slRow = llrCell.Value + 1
slColumn = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
Set srg = sws.Range("A1", sws.Cells(slRow, slColumn))
srg.Copy dfCell
' If you only need to copy values (since you're using '.ClearContents'),
' instead, use the most efficient:
'dfCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set llrCell = llrCell.Offset(1) ' next source last row lookup cell
Set dfCell = dfCell.Offset(srg.Rows.Count) ' next first dest. cell
Next i
End Sub
The counter and the lng_lastRow variable is too messy.
I repaleced some code as follow：
Sub newLoop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range, rng_lastRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("Control")
ws_Sheet.Cells.ClearContents
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
Set rng_lastRange = ws_Sheet.Cells(Rows.Count, 1).End(xlUp)
lng_LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy rng_lastRange.Offset(1, 0)
Next i
End Sub
I am trying to hide multiple rows in an excel worksheet which are empty using following code however i am getting error message "Argument not optional". What could be wrong in the code?
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count, col_count As Integer
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
mainrange.Range.SpecialCells(xlCellTypeBlanks).Rows.Hidden = True
End Sub
Based on your code and assuming first row in your sheet is never empty you could do something like that
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count As Long, col_count As Long
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
Dim i As Long
For i = 1 To col_count - 1
mainrange.AutoFilter field:=i, Criteria1:="="
Next i
Dim rg As Range
Set rg = mainrange.SpecialCells(xlCellTypeVisible)
mainrange.AutoFilter
rg.Rows.EntireRow.Hidden = True
rg.Rows(1).EntireRow.Hidden = False
End Sub
An if you turn off screenupdating etc. it should be pretty fast as well
I'm trying to get a unique range pfrom Sheet A (pivot summarizing my data on an irrelevant master sheet) to paste on another sheet Sheet B (New Blank sheet). Below is my code for this. I get a runtime error "AdvancedFilter method of Range class failed". I have literally tried everything for hours and have no idea what else to do.
Public Function FindRow(ByVal sht As Worksheet, ByVal r As Long, ByVal c As Long, ByVal Match As Variant) As Long
Do While Cells(r, c) <> Match
r = r + 1
Loop
FindRow = r
End Function
Sub ExtractFromPivot()
Dim PivotSheet As Worksheet
Dim RandomSheet As Worksheet
Dim Newsheet As Worksheet
Dim Newbook As Workbook
Dim Fundname As String
Dim FilePath As String
Dim Copyrange As String
Dim fr As Long
Dim lr As Long
Set RandomSheet = ThisWorkbook.Worksheets.Add
Set PivotSheet = ThisWorkbook.Worksheets("Extract Pivot")
'Clears all filters on 'Name' (believe me I tried .clearallfilters
With ThisWorkbook.SlicerCaches("Slicer_Client_Name")
.SlicerItems("a").Selected = True
.SlicerItems("b").Selected = True
.SlicerItems("c").Selected = True
End With
lr = FindRow(PivotSheet, 30, 1, "")
Let Copyrange = "A31" & ":" & "A" & lr
PivotSheet.Range(Copyrange).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=RandomSheet.Cells(1, 1), Unique:=True
I am trying to:
open an import file
check for identical values of import file in target file in several columns
if matched, update one cell in target file
if not matched, add another row
This is my code so far (I didn't clean it yet):
Public Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
Sub Import_Macro()
Dim wbData As Workbook
Dim wsData As Worksheet
Dim rngData As Range
Set rngData = Selection
Set wbData = Workbooks(rngData.Parent.Parent.Name)
Set wsData = wbData.Sheets("Fehleranalyse Daten")
'DATA IMPORT
Dim wbImport As Workbook
Dim wsImport As Worksheet
Dim Lastrow_wsData As String
Dim Lastrow_wsData_neu As String
Lastrow_wsData = wsData.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Import from file
MyPath = Application.ActiveWorkbook.Path
SetCurrentDirectoryA MyPath
strFileToOpen = Application.GetOpenFilename _
(Title:="Bitte Datei für Fehler-Reporting auswählen", _
FileFilter:="Excel Files *.xls*; *.csv (*.xls*; *.csv),")
'Defining names for Import
Dim rngImport As Range
Set rngImport = Selection
Set wbImport = Workbooks(rngImport.Parent.Parent.Name)
Set wsImport = wbImport.Sheets("Sheet1")
Dim Lastrow_Import As Long
Lastrow_Import = wsImport.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim AnmelderImport As Long
Dim AnmelderData As Long
Dim AbteilungImport As Long
Dim AbteilungData As Long
Dim VNrImport As Long
Dim VNrData As Long
Dim AuftragsNrImport As Long
Dim AuftragsNrData As Long
Dim VersuchImport As Long
Dim VersuchData As Long
Dim iCol As Long
Dim colnameData As Variant
Dim colnumImport As Variant
Dim lrData As Long
Dim lcData As Long
Dim lcImport As Long
Dim lrs As Long
Dim r As Long
Dim c As Long
Dim iSOP As Long
Dim j As Long
Dim i As Range
Dim k As Range
Dim n As Long
Dim Check As Variant
Dim arr As Variant
'Creating several array I need to either check for matching or copying
VersuchImport = Application.WorksheetFunction.Match("VERSUCH", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Versuch
VersuchData = Application.WorksheetFunction.Match("VERSUCH", wsData.Range("1:1"), 0)
AuftragsNrImport = Application.WorksheetFunction.Match("AUFTRAGSNUMMER", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Auftragsnr.
AuftragsNrData = Application.WorksheetFunction.Match("AUFTRAGSNUMMER", wsData.Range("1:1"), 0)
TestzweckImport = Application.WorksheetFunction.Match("TESTZWECK", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Testzweck
TestzweckData = Application.WorksheetFunction.Match("TESTZWECK", wsData.Range("1:1"), 0)
StatusImport = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Status
StatusData = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", wsData.Range("1:1"), 0)
Debug.Print "VersuchImport = " & VersuchImport
Debug.Print "VersuchData = " & VersuchData
Debug.Print "AuftragsNrImport = " & AuftragsNrImport
Debug.Print "AuftragsNrData = " & AuftragsNrData
Debug.Print "TestzweckImport = " & TestzweckImport
Debug.Print "TestzweckData = " & TestzweckData
With wsImport
Check = .Range(.Cells(1, VersuchImport).Address, .Cells(Lastrow_Import, VersuchImport).End(xlUp).Address).Value2 & .Range(.Cells(1, AuftragsNrImport).Address, .Cells(Lastrow_Import, Auftragsnr).End(xlUp).Address).Value2
End With
'I'm creating another array with column names to be copied (bayed on target file)
With wsData
lrData = wsData.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lcData = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", .Range("1:1"), 0)
colnameData = Application.Transpose(.Range(.Cells(1, 1), .Cells(1, lcData)).Value)
End With
'The corresponding array in the source file
With wsImport
lcImport = Application.WorksheetFunction.Match("SORTIERUNG", .Range("11:11"), 0)
ReDim colnumImport(lcImport, 1)
For iCol = 1 To lcImport
On Error Resume Next
colnumImport(iCol, 1) = .Rows(11).Find(What:=colnameData(iCol, 1), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Next iCol
End With
'This section copies all relevant columns and rows if not matched (not cleaned up though)
Dim lcellData As Range
Dim cellAuftragsNrImport As Range
Dim RngAuftragsNrImport As Variant
Dim RngAuftragsNrData As Variant
Dim Status As Long
Dim cellVersuchImport As Range
Dim RngVersuchImport As Variant
Dim RngVersuchData As Variant
Dim cellStatusImport As Range
Dim RngStatusImport As Variant
Dim RngStatusData As Variant
Dim cellTestzweckImport As Range
Dim RngTestzweckImport As Variant
Dim RngTestzweckData As Variant
Dim iZweck As Long
With wsImport
RngAuftragsNrImport = .Range(.Cells(12, AuftragsNrImport).Address, .Cells(Lastrow_Import, AuftragsNrImport).Address).Value2
RngTestzweckImport = .Range(.Cells(12, TestzweckImport).Address, .Cells(Lastrow_Import, TestzweckImport).Address).Value2
RngVersuchImport = .Range(.Cells(12, VersuchImport).Address, .Cells(Lastrow_Import, VersuchImport).Address).Value2
RngStatusImport = .Range(.Cells(12, StatusImport).Address, .Cells(Lastrow_Import, StatusImport).Address).Value2
End With
With wsData
RngAuftragsNrData = .Range(.Cells(3, AuftragsNrData).Address, .Cells(Lastrow_wsData, AuftragsNrData).Address).Value2
RngVersuchData = .Range(.Cells(3, VersuchData).Address, .Cells(Lastrow_wsData, VersuchData).Address).Value2
RngStatusNrData = .Range(.Cells(3, StatusData).Address, .Cells(Lastrow_wsData, StatusData).Address).Value2
RngTestzweckNrData = .Range(.Cells(3, TestzweckData).Address, .Cells(Lastrow_wsData, TestzweckData).Address).Value2
End With
ReDim arr(0)
For iZweck = LBound(RngTestzweckImport, 1) To UBound(RngTestzweckImport, 1)
If RngTestzweckImport(iZweck, 1) = "Entwicklungstest" Then
ReDim Preserve arr(j)
arr(j) = iZweck + 11
j = j + 1
End If
Next iZweck
For Each cellAuftragsNrImport In RngAuftragsNrImport
With wsData.Cells 'RngAuftragsNrData.Cells
Set i = .Find(cellAuftragsNrImport, LookIn:=xlValues, lookat:=xlWhole)
If Not i Is Nothing Then
k = i.Row
Status = .Cells(k, StatusData).Value
If cellStatusImport.Value <> Status Then
cellStatusImport.Copy Destination:=wsData.Cells(i.Row, StatusData)
End If
Else
With wsData
lrData = Lastrow_wsData
For r = LBound(arr) To UBound(arr)
lrData = .Cells(.Rows.Count, 1).End(xlUp).Row
For c = 1 To lcData
.Cells(lrData + 1, c).Value = wsImport.Cells(arr(r), colnumImport(c, 1)).Value
Next c
Next r
End With
End If
End With
Next
End Sub
All names ending with "Import" are from the source file. All names ending with "Data" are for the target file.
I'm trying to:
Check if items of the source file are already part of the target file. That applies only to lines that contain the value "Entwicklungstest" (see arr).
The criteria to be checked are: AuftragsNr (Order ID), Testzweck and Date.
So far my macro only checks for AuftragsNr. Even for that single criteria, my macro doesn't work.
So basically, if the three criteria from above are not met in the target file, a new line should be added. If the criteria are met, the column "Status" must be updated with the value from the source file.
When executing the macro, all it does is add all lines with "Entwicklungstest" after the last row of the target file.
I have a code to copy the entire row if column B contains a certain text ("ACK-", but now I need to copy the entire row directly above the one with the certain text ("ACK-". Is this even possible? Any help will be appreciated.
Sub HEA_Filter()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
To reference "the row above", you can use the Range.Offset method:
rngCells.Offset(-1).EntireRow.Copy wsDest.Range("A" & DestNoRows)
' ^^^^^^^^^^^^
However, be aware that this raised a runtime error if the range is at row 1, because row 0 does not exist. You might want to add a check for it, for example:
If rngCells.Row > 1 Then rngCells.Offset(-1).EntireRow.Copy ...