Guidance with automation/efficiency of macro or concept of macro to move certain cells based on a value in a row

Question

I have a spreadsheet that is used to log inventory adjustments. Due to circumstances, I need to also list this data in another log that includes adjustments made by multiple individuals. Is there a way to condense/improve upon the current method I have?

I have looked around this site and others trying to build some understanding, copying code when I can because I am by no means an intermediate user.

Option Explicit
Sub moveInput()

'Worksheets("test").Range("A3:G3").Copy
'Workbooks("Book2").Worksheets("Sheet7").Activate
'Range("A1").End(xlDown).Offset(1, 0).Select

Workbooks("Book1").Worksheets("test").Range("A3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("B3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("B1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("C3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("C1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("D3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("D1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("E3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("J1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("F3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("M1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("G3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("Q1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

End Sub

Option Explicit
Sub moveInput_2()
'*****************'
'Declare Variables'
'*****************'
Dim lastRow As Long
Dim wB1 As Workbook
Dim wB2 As Workbook
Dim wsTest As Worksheet
Dim ws7 As Worksheet
Dim i As Integer
'*************'
'Set Variables'
'*************'
Set wB2 = Workbooks("Book2.xlsm")
Set ws7 = wB2.Sheets("Sheet7")
Set wB1 = Workbooks("Book1.xlsm")
Set wsTest = wB1.Sheets("test")
i = 1
'***********************'
'Find Last Row For Input'
'***********************'
'On Error GoTo errlastrow
With ws7
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastRow = 1
    End If
End With
'On Error GoTo 0
'****************************'
'Find Rows That Need Transfer'
'****************************'
'On Error GoTo errinput
With wsTest
    For i = 1 To 250
        If .Cells(i, 6).Value > 300 Then
            wB2.ws7.Range(lastRow, 1).Value = wB1.wsTest.Range(i, 1).Value 'Error pops up here, object doesn't support this property or method
'I've tried switching them around, including wb, sheet, range and nothing.
            ws7.Range("lastrow, 2").Value = wsTest.Range(i, 2).Value
            ws7.Range("lastrow, 1").Value = wsTest.Range(i, 3).Value
            ws7.Range("lastrow, 1").Value = wsTest.Range(i, 4).Value
            ws7.Range("lastrow, 10").Value = wsTest.Range(i, 5).Value
            ws7.Range("lastrow, 13").Value = wsTest.Range(i, 6).Value
            ws7.Range("lastrow, 17").Value = wsTest.Range(i, 7).Value
        End If
    Next i
    lastRow = lastRow + 1
End With
'On Error GoTo 0
Exit Sub
'**************'
'Error Handling'
'**************'
'errlastrow:
'MsgBox "Could not find last row, check dataset!" & Err.Description
'End
'errinput:
'MsgBox "No data to input" & Err.Description
'End
End Sub

My end goal is to have macro(preferably assigned to a button) that will identify rows where my cost value will be over a certain dollar amount, then copy and paste certain cells from that row to the main log. The rows and columns would not be the same. It would also be helpful, but not necessary(I could look around), to be able to check for active users when opening the separate workbook and cancel actions if there are any.

I would suggest avoiding `End(xlDown)`. See [this answer](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-vba) for a detailed explanation why and for alternatives. — BigBen, Apr 27 '19 at 03:44
@BigBen Thanks, i had heard it was ill advised to use `EndxlDown`, but I had recently watched a wiseowl video and I thought my dataset was simple enough it wouldn't matter. Now that I think about it though, it was cause big problems if someone had left values somewhere on the page. — sTan_The_mAn, Apr 27 '19 at 22:27

score 0 · Answer 1 · answered Apr 27 '19 at 02:49

My advice would be to stop using the clipboard. If you use your clipboard while the macro is running then you could end up with undesired results. Other than that, your code isn't bad. It's pretty simple.

Sub moveInput()

'Worksheets("test").Range("A3:G3").Copy
'Workbooks("Book2").Worksheets("Sheet7").Activate
'Range("A1").End(xlDown).Offset(1, 0).Select



Workbooks("Book2").Worksheets("Sheet7").Range("A1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("A3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("B1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("B3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("C1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("C3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("D1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("D3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("J1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("E3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("M1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("F3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("Q1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("G3").Value

End Sub

Thanks for the heads up on the clipboard. Hadn't run into an issue yet thankfully. I've edited the post with updates to my attempt. Basically trying loop this function in the event a value is greater than or equal to a number in column F. — sTan_The_mAn, Apr 27 '19 at 22:20

score 0 · Accepted Answer · answered Apr 27 '19 at 18:32

Maybe something like this:

Option Explicit

Sub MoveInput()
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("test")

    Dim destinationSheet As Worksheet
    Set destinationSheet = ThisWorkbook.Worksheets("Sheet7")

    Dim copyPasteMap As Variant ' (SourceColumn, DestinationColumn), (SourceColumn, DestinationColumn), etc.
    copyPasteMap = Array(Array("A", "A"), _
                        Array("B", "B"), _
                        Array("C", "C"), _
                        Array("D", "D"), _
                        Array("E", "J"), _
                        Array("F", "M"), _
                        Array("G", "Q") _
                        )

    Dim lastRowOnDestinationSheet As Long
    lastRowOnDestinationSheet = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row

    Dim index As Long
    For index = LBound(copyPasteMap) To UBound(copyPasteMap)
        Dim sourceColumnLetter As String
        sourceColumnLetter = copyPasteMap(index)(0)

        Dim destinationColumnLetter As String
        destinationColumnLetter = copyPasteMap(index)(1)

        destinationSheet.Cells(lastRowOnDestinationSheet + 1, destinationColumnLetter).Value = sourceSheet.Cells(3, sourceColumnLetter).Value
    Next index
End Sub

copyPasteMap is basically just an array of 2-item arrays. Each 2-item array contains the source column (the column that we're copying from) and the destination column (the column that we're pasting to).

I use Array() function since it's relatively convenient, but alternatives might include creating a custom type/class, or using some kind of associated key-value structure.

This also means that if you need to copy and paste more columns, then you can just update the copyPasteMap variable (and the loop will take care of the actual copy-pasting). I think it's best to try not to repeat yourself when programming and I hope my code makes sense to you. Good luck.

I like it, looks a lot cleaner than mine. I don't fully understand it, specifically the lbound and ubound. And it doesn't seem to jump and grab the next input row, just the same row over and over. Do you think I could incorporate this to my updated attempt? Or scrap it and tinker with this one? — sTan_The_mAn, Apr 27 '19 at 22:23
@sTan_The_mAn, `Lbound` and `Ubound` are functions which give you the start and end of the array. The `For` loop can then loop over the array once we know where to start and end. The reason why my answer only copy-pastes one row is because that was what your code did. In `moveInput_2` I think you could use `Range.Autofilter` and specify `">300"` as criteria. You can then copy-paste the columns you need. By the way, `Range("lastrow, 2")` is not a valid range. You should use `Cells(lastrow, "B")` (take care not to put `lastrow` in quotes). `Range` and `Cells` are different in what they accept. — chillin, Apr 28 '19 at 00:36
Sorry, sometimes I have my head in the clouds and assume people already know my thought process. My plan was to cut out extra code and loop it through 250 rows max. The array approach looks like it would make everything simple and smooth, but I lack any knowledge about it, making it harder to deal with than the paltry amount of vba knowledge I do have. Maybe once I get better. — sTan_The_mAn, Apr 28 '19 at 05:19
@sTan_The_mAn, hey again, just wanted to give you a heads up. I think your code (in your own answer) will skip rows due to this line `i = i + 1` inside your `For` loop. Maybe this is exactly what you wanted, but I mention it in case it's not. The implications of this are that `ws7` will only have 125 rows transferred to it (if my maths/thinking is correct), not the 250. Also, when using `Range.Autofilter` you can use `Range.specialcells(xlcelltypevisible)` to copy-paste only the cells that the filter shows (and not all cells). I know you say you'll worry about it later, but just a heads up. — chillin, Apr 28 '19 at 07:19

score 0 · Answer 3 · answered Apr 28 '19 at 05:13

So this is what I have come down to, if anyone was interested. My only problem is that it writes everything even when filtered. Small snag, I can worry about that later.

Option Explicit
Sub moveInput_2()
'*****************'
'Declare Variables'
'*****************'
Dim lastRow As Long
Dim wB1 As Workbook
Dim wB2 As Workbook
Dim wsTest As Worksheet
Dim ws7 As Worksheet
Dim i As Long
Dim j As Long
'*************'
'Set Variables'
'*************'
Set wB2 = Workbooks("Book2")
Set ws7 = wB2.Sheets("Sheet7")
Set wB1 = Workbooks("Book1")
Set wsTest = wB1.Sheets("test")
i = 1
j = 1
'***********************'
'Find Last Row For Input'
'***********************'
On Error GoTo errlastrow
With ws7
ws7.Activate
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastRow = 1
    End If
End With
On Error GoTo 0
'****************************'
'Find Rows That Need Transfer'
'****************************'
On Error GoTo errinput
With wsTest
wsTest.Activate
    Range("A1:G1").AutoFilter field:=6, Criteria1:=">300", Operator:=xlFilterValues
        For i = 2 To 250
            ws7.Cells(lastRow, "A").Offset(1, 0).Value = wsTest.Cells(i, 1).Value
            ws7.Cells(lastRow, "B").Offset(1, 0).Value = wsTest.Cells(i, 2).Value
            ws7.Cells(lastRow, "C").Offset(1, 0).Value = wsTest.Cells(i, 3).Value
            ws7.Cells(lastRow, "D").Offset(1, 0).Value = wsTest.Cells(i, 4).Value
            ws7.Cells(lastRow, "J").Offset(1, 0).Value = wsTest.Cells(i, 5).Value
            ws7.Cells(lastRow, "M").Offset(1, 0).Value = wsTest.Cells(i, 6).Value
            ws7.Cells(lastRow, "Q").Offset(1, 0).Value = wsTest.Cells(i, 7).Value
            lastRow = lastRow + 1
            i = i + 1
        Next i
End With
On Error GoTo 0
Exit Sub
'**************'
'Error Handling'
'**************'
errlastrow:
MsgBox "Could not find last row, check dataset!" & Err.Description
End
errinput:
MsgBox "No data to input!" & Err.Description
End
End Sub

Thank you to everyone who answered.

Guidance with automation/efficiency of macro or concept of macro to move certain cells based on a value in a row

3 Answers3