Copy/paste values if the cell next to it is empty every month

Mortenhoey

New Member
Joined
Apr 12, 2021
Messages
32
Office Version
  1. 365
Platform
  1. Windows
Is there a way i can copy paste specific rows to the excel ark. The things i need:

- copy paste e3, e4, e9, e13 and e15 from mappe2 (book) to mappe 1 (book)
- has to copy the value in the given row if the cell next to it is empty
- the macro has to be applied from mappe1 (book)
- next month the may values (which is coming, later at the month) and run it again so it is the may values which copies to mappe1 (book)
- The workbooks has to be open

So the point is to always copy paste the lastest value from mappe2 (book) to mappe 1 - month by month.

In mappe1 there are maybe more variables to come to maybe in two months there has to e3,e4,e9,e13,e15 and add e5 and e14.

So if I can put more rows in the macro for future months copy paste it would be perfect.

I really can figure out to make the macro for choosing a value if the next cell is empty and the same when pasting it in mappe1 (book)

Link to: Photo

Thank you for the help.
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
Try the code below in a standard module (make sure that you save the workbook before running the macro):
VBA Code:
Sub GetValuesFromSpecificCellsInAnotherWorkbook()
    Dim src As Workbook, desOutput As Worksheet, desCellList As Worksheet, lr As Long, srcAddresses() As String, srcSheets() As String, skip() As Boolean
    Dim i As Long, j As Long, k As Long, errSheets() As String, Canceled As Boolean
    
    'OPTIMIZE MACRO SPEED
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'GET THE SOURCE FILE AND DEFINE RELEVANT WORKSHEETS
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select the source file"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel files", "*.xls*"
        If .Show <> -1 Then
            Canceled = True
            GoTo ResetSettings
        End If
        Set src = Workbooks.Open(Filename:=.SelectedItems(1))
    End With
    Set desOutput = ThisWorkbook.Worksheets("POPdata")
    Set desCellList = ThisWorkbook.Worksheets("EmilKPI")
    
    'GET THE CELL ADDRESSES OF SOURCE DATA
    With desCellList
        lr = .Range("C:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If lr = 1 Then
            MsgBox "There's no reference in " & desCellList.Name, vbExclamation, "Error"
            Canceled = True
            GoTo ResetSettings
        End If
        For i = 2 To lr
            ReDim Preserve srcAddresses(j)
            ReDim Preserve srcSheets(j)
            ReDim Preserve skip(j)
            srcAddresses(j) = .Cells(i, "D") & .Cells(i, "C")
            srcSheets(j) = .Cells(i, "E")
            If SheetExists(srcSheets(j), src) = False Then
                skip(j) = True
                If IsInArray(srcSheets(j), errSheets) = False And srcSheets(j) <> "" Then
                    ReDim Preserve errSheets(k)
                    errSheets(k) = srcSheets(j)
                    k = k + 1
                End If
            ElseIf .Cells(i, "C") = "" Or .Cells(i, "D") = "" Or .Cells(i, "E") = "" Then
                skip(j) = True
            Else
                skip(j) = False
            End If
            j = j + 1
        Next i
    End With
    
    'OUTPUT DATA
    With desOutput
        j = 2
        For i = LBound(srcAddresses) To UBound(srcAddresses)
            If skip(i) = False Then
                .Cells(j, "B") = src.Worksheets(srcSheets(i)).Range(srcAddresses(i)).Text
            End If
            j = j + 1
        Next i
        .Activate
    End With
    
ResetSettings:
    'RESET MACRO OPTIMIZATION SETTINGS
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    If Canceled Then
        MsgBox "Procedure canceled.", vbInformation, "Canceled"
    Else
        If IsArrayEmpty(errSheets) Then
            MsgBox "Procedure complete.", vbInformation, "Complete"
        Else
            MsgBox "Procedure complete." & vbCrLf & vbCrLf & "※The following sheets were not found:" & vbCrLf & Join(errSheets, ", "), vbInformation, "Complete"
        End If
    End If

End Sub

Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
    On Error GoTo 0
    IsInArray = False
End Function

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = True
    IsArrayEmpty = UBound(arr) < LBound(arr)
End Function

Function SheetExists(WorksheetName As String, Optional ParentWorkbook As Workbook) As Boolean
    Dim ws As Worksheet
    If ParentWorkbook Is Nothing Then Set ParentWorkbook = ThisWorkbook
    For Each ws In ParentWorkbook.Worksheets
        If ws.Name = WorksheetName Then
            SheetExists = True
            Exit Function
        End If
    Next ws
End Function
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
This one updates column values in EmilKPI automatically.
VBA Code:
Sub GetValuesFromSpecificCellsInAnotherWorkbook()
    Dim src As Workbook, desOutput As Worksheet, desCellList As Worksheet, lr As Long, srcAddresses() As String, srcSheets() As String, skip() As Boolean
    Dim i As Long, j As Long, k As Long, errSheets() As String, Canceled As Boolean
   
    'OPTIMIZE MACRO SPEED
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'GET THE SOURCE FILE AND DEFINE RELEVANT WORKSHEETS
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select the source file"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel files", "*.xls*"
        If .Show <> -1 Then
            Canceled = True
            GoTo ResetSettings
        End If
        Set src = Workbooks.Open(Filename:=.SelectedItems(1))
    End With
    Set desOutput = ThisWorkbook.Worksheets("POPdata")
    Set desCellList = ThisWorkbook.Worksheets("EmilKPI")

    'UPDATE COLUMNS IN EmilKPI
    Call UpdateEmilKPI(src)
   
    'GET THE CELL ADDRESSES OF SOURCE DATA
    With desCellList
        lr = .Range("C:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If lr = 1 Then
            MsgBox "There's no reference in " & desCellList.Name, vbExclamation, "Error"
            Canceled = True
            GoTo ResetSettings
        End If
        For i = 2 To lr
            ReDim Preserve srcAddresses(j)
            ReDim Preserve srcSheets(j)
            ReDim Preserve skip(j)
            srcAddresses(j) = .Cells(i, "D") & .Cells(i, "C")
            srcSheets(j) = .Cells(i, "E")
            If SheetExists(srcSheets(j), src) = False Then
                skip(j) = True
                If IsInArray(srcSheets(j), errSheets) = False And srcSheets(j) <> "" Then
                    ReDim Preserve errSheets(k)
                    errSheets(k) = srcSheets(j)
                    k = k + 1
                End If
            ElseIf .Cells(i, "C") = "" Or .Cells(i, "D") = "" Or .Cells(i, "E") = "" Then
                skip(j) = True
            Else
                skip(j) = False
            End If
            j = j + 1
        Next i
    End With
   
    'OUTPUT DATA
    With desOutput
        j = 2
        For i = LBound(srcAddresses) To UBound(srcAddresses)
            If skip(i) = False Then
                .Cells(j, "B") = src.Worksheets(srcSheets(i)).Range(srcAddresses(i)).Text
            End If
            j = j + 1
        Next i
        .Activate
    End With
   
ResetSettings:
    'RESET MACRO OPTIMIZATION SETTINGS
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    If Canceled Then
        MsgBox "Procedure canceled.", vbInformation, "Canceled"
    Else
        If IsArrayEmpty(errSheets) Then
            MsgBox "Procedure complete.", vbInformation, "Complete"
        Else
            MsgBox "Procedure complete." & vbCrLf & vbCrLf & "※The following sheets were not found:" & vbCrLf & Join(errSheets, ", "), vbInformation, "Complete"
        End If
    End If

End Sub

Sub UpdateEmilKPI(ByVal src As Workbook)
    Dim lr As Long, i As Long, noData As Boolean, independent As Boolean, Canceled As Boolean
   
    With ThisWorkbook.Worksheets("EmilKPI")
   
        .Activate
        Application.ScreenUpdating = False
        lr = .Cells(Rows.Count, "C").End(xlUp).Row
        If lr = 1 Then
            noData = True
            If src Is Nothing Then independent = True
            GoTo ResetSettings
        End If
        If src Is Nothing Then
            With Application.FileDialog(msoFileDialogFilePicker)
                .Title = "Select the source file"
                .AllowMultiSelect = False
                .Filters.Clear
                .Filters.Add "Excel files", "*.xls*"
                If .Show <> -1 Then
                    Canceled = True
                    GoTo ResetSettings
                End If
                Set src = Workbooks.Open(Filename:=.SelectedItems(1))
                independent = True
            End With
        End If
        For i = 2 To lr
            If .Cells(i, "C") <> "" And SheetExists(.Cells(i, "E"), src) Then
                .Cells(i, "D").Value = Split(src.Worksheets(.Cells(i, "E").Value).Cells(.Cells(i, "C").Value, Columns.Count).End(xlToLeft).Address, "$")(1)
            End If
        Next i
       
    End With
   
ResetSettings:
    Application.ScreenUpdating = True
    If independent And noData Then
        MsgBox "There is no data to update.", vbExclamation, "Error"
    ElseIf Canceled Then
        MsgBox "List updating canceled.", vbInformation, "Canceled"
    End If
   
End Sub

Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
    On Error GoTo 0
    IsInArray = False
End Function

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = True
    IsArrayEmpty = UBound(arr) < LBound(arr)
End Function

Function SheetExists(WorksheetName As String, Optional ParentWorkbook As Workbook) As Boolean
    Dim ws As Worksheet
    If ParentWorkbook Is Nothing Then Set ParentWorkbook = ThisWorkbook
    For Each ws In ParentWorkbook.Worksheets
        If ws.Name = WorksheetName Then
            SheetExists = True
            Exit Function
        End If
    Next ws
End Function
Yet you're going to have to specify the rows and worksheets manually:
1168445a Get specific values from another workbook.xlsm
CDE
1RowsColumnsWorksheets
2155CIOTNI
3157CIOTNI
4161CIOTNI
5159CIOTNI
EmilKPI

This code only updates the columns.
 
Last edited:

Mortenhoey

New Member
Joined
Apr 12, 2021
Messages
32
Office Version
  1. 365
Platform
  1. Windows
Seems like it works! Is there a way i can add more into EmilKPI so it takes values from more rows in the future (if it is needed)
 

Mortenhoey

New Member
Joined
Apr 12, 2021
Messages
32
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

And is there a way i can add one more workbook to get values from? :) like OTNI
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
Seems like it works! Is there a way i can add more into EmilKPI so it takes values from more rows in the future (if it is needed)
Alright, I'll explain how the code works.
Now my test workbook looks like:
1168445a Get specific values from another workbook.xlsm
ABCDE
1KPIERRowsColumnsWorksheets
2155CIOTNI
3157CIOTNI
4161CIOTNI
5159CIOTNI
6CIOTNI
7CIOTNI
8CIOTNI
9CIOTNI
10CIOTNI
11CIOTNI
12CIOTNI
13CIOTNI
14CIOTNI
15CIOTNI
16141CIOTNI
17145CIOTNI
18CIOTNI
19CIOTNI
20CIOTNI
21CIOTNI
22CIOTNI
23CIOTNI
24CIOTNI
25181CIOTNI
26CIOTNI
27CIOTNI
28CIOTNI
29KPI
303LKPI
EmilKPI

To transfer data to POPdata, "Rows", "Columns", and "Worksheets" all need to be filled, and if these conditions are met, values are outputted to POPdata:
1168445a Get specific values from another workbook.xlsm
AB
1Header
2DATA69.40%
3DATA32.40%
4DATA11.00%
5DATA45.80%
6DATA
7DATA
8DATA
9DATA
10DATA
11DATA
12DATA
13DATA
14DATA
15DATA
16DATA75.80%
17DATA44.50%
18DATA
19DATA
20DATA
21DATA
22DATA
23DATA
24DATA
25DATA85.90%
26DATA
27DATA
28DATA
29DATA
30DATA
POPdata

Notice that the row numbers of the cells into which values are outputted are exactly the same.
So, if you need to add rows, insert rows the exact same way. For example:
1168445a Get specific values from another workbook.xlsm
ABC
1Header
2DATA69.40%
3DATA32.40%
4DATA11.00%
5DATA45.80%
6DATA
7ADDED
8DATA
9DATA
10DATA
11DATA
12ADDED
13DATA
14DATA
15DATA
POPdata

1168445a Get specific values from another workbook.xlsm
CDEF
1RowsColumnsWorksheets
2155CIOTNI
3157CIOTNI
4161CIOTNI
5159CIOTNI
6CIOTNI
7ADDED
8CIOTNI
9CIOTNI
10CIOTNI
11CIOTNI
12ADDED
13CIOTNI
14CIOTNI
15CIOTNI
EmilKPI
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

And is there a way i can add one more workbook to get values from? :) like OTNI
That's a different story so the code needs to be modified further.
Perhaps I'll work on it when I have time.
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
Incorporated the function mentioned in #37:
VBA Code:
Dim src2 As Workbook

Sub GetValuesFromSpecificCellsInAnotherWorkbook2()
    Dim src() As Workbook, desOutput As Worksheet, desCellList As Worksheet, lr As Long, srcAddresses() As String, srcSheets() As String, skip() As Boolean
    Dim i As Long, j As Long, k As Long, errSheets() As String, Canceled As Boolean, srcBooks() As String
    
    'OPTIMIZE MACRO SPEED
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'GET THE SOURCE FILE AND DEFINE RELEVANT WORKSHEETS
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select the source file"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Excel files", "*.xls*"
        If .Show <> -1 Then
            Canceled = True
            GoTo ResetSettings
        End If
        For i = 1 To .SelectedItems.Count
            ReDim Preserve src(i - 1)
            Set src(i - 1) = Workbooks.Open(Filename:=.SelectedItems(i))
        Next i
    End With
    Set desOutput = ThisWorkbook.Worksheets("POPdata")
    Set desCellList = ThisWorkbook.Worksheets("EmilKPI")

    'UPDATE COLUMNS IN EmilKPI
    Call UpdateEmilKPI2(src)
    
    'GET THE CELL ADDRESSES OF SOURCE DATA
    With desCellList
        lr = .Range("C:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If lr = 1 Then
            MsgBox "There's no reference in " & desCellList.Name, vbExclamation, "Error"
            Canceled = True
            GoTo ResetSettings
        End If
        For i = 2 To lr
            ReDim Preserve srcAddresses(j)
            ReDim Preserve srcSheets(j)
            ReDim Preserve srcBooks(j)
            ReDim Preserve skip(j)
            srcAddresses(j) = .Cells(i, "D") & .Cells(i, "C")
            srcSheets(j) = .Cells(i, "E")
            If SheetExists2(srcSheets(j), src) = False Then
                srcBooks(j) = ""
                skip(j) = True
                If IsInArray(srcSheets(j), errSheets) = False And srcSheets(j) <> "" Then
                    ReDim Preserve errSheets(k)
                    errSheets(k) = srcSheets(j)
                    k = k + 1
                End If
            ElseIf .Cells(i, "C") = "" Or .Cells(i, "D") = "" Or .Cells(i, "E") = "" Then
                srcBooks(j) = ""
                skip(j) = True
            Else
                srcBooks(j) = src2.Name
                skip(j) = False
            End If
            j = j + 1
        Next i
    End With
    
    'OUTPUT DATA
    With desOutput
        j = 2
        For i = LBound(srcAddresses) To UBound(srcAddresses)
            If skip(i) = False Then
                .Cells(j, "B") = Workbooks(srcBooks(i)).Worksheets(srcSheets(i)).Range(srcAddresses(i)).Text
            End If
            j = j + 1
        Next i
        .Activate
    End With
    
ResetSettings:
    'RESET MACRO OPTIMIZATION SETTINGS
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    If Canceled Then
        MsgBox "Procedure canceled.", vbInformation, "Canceled"
    Else
        If IsArrayEmpty(errSheets) Then
            MsgBox "Procedure complete.", vbInformation, "Complete"
        Else
            MsgBox "Procedure complete." & vbCrLf & vbCrLf & "※The following sheets were not found:" & vbCrLf & Join(errSheets, ", "), vbInformation, "Complete"
        End If
    End If

End Sub

Sub UpdateEmilKPI2(src() As Workbook)
    Dim lr As Long, i As Long, noData As Boolean, independent As Boolean, Canceled As Boolean
    
    With ThisWorkbook.Worksheets("EmilKPI")
    
        .Activate
        Application.ScreenUpdating = False
        lr = .Cells(Rows.Count, "C").End(xlUp).Row
        If lr = 1 Then
            noData = True
            If IsArrayEmpty(src) Then independent = True
            GoTo ResetSettings
        End If
        If IsArrayEmpty(src) Then
            With Application.FileDialog(msoFileDialogFilePicker)
                .Title = "Select the source file"
                .AllowMultiSelect = True
                .Filters.Clear
                .Filters.Add "Excel files", "*.xls*"
                If .Show <> -1 Then
                    Canceled = True
                    GoTo ResetSettings
                End If
                For i = 1 To .SelectedItems.Count
                    ReDim Preserve src(i - 1)
                    Set src(i - 1) = Workbooks.Open(Filename:=.SelectedItems(i))
                Next i
            End With
        End If
        For i = 2 To lr
            If .Cells(i, "C") <> "" And SheetExists2(.Cells(i, "E"), src) Then
                .Cells(i, "D").Value = Split(src2.Worksheets(.Cells(i, "E").Value).Cells(.Cells(i, "C").Value, Columns.Count).End(xlToLeft).Address, "$")(1)
            End If
        Next i
        
    End With
    
ResetSettings:
    Application.ScreenUpdating = True
    If independent And noData Then
        MsgBox "There is no data to update.", vbExclamation, "Error"
    ElseIf Canceled Then
        MsgBox "List updating canceled.", vbInformation, "Canceled"
    End If
    
End Sub

Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
    On Error GoTo 0
    IsInArray = False
End Function

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = True
    IsArrayEmpty = UBound(arr) < LBound(arr)
End Function

Function SheetExists2(WorksheetName As String, ParentWorkbook() As Workbook) As Boolean
    Dim i As Long, ws As Worksheet
    'If ParentWorkbook Is Nothing Then Set ParentWorkbook = ThisWorkbook
    For i = LBound(ParentWorkbook) To UBound(ParentWorkbook)
        For Each ws In ParentWorkbook(i).Worksheets
            If ws.Name = WorksheetName Then
                SheetExists2 = True
                Set src2 = ParentWorkbook(i)
                Exit Function
            End If
        Next ws
    Next i
End Function
 

Mortenhoey

New Member
Joined
Apr 12, 2021
Messages
32
Office Version
  1. 365
Platform
  1. Windows
Looks very good. I am testing i later today. Thanks you for the help! :)
 

Watch MrExcel Video

Forum statistics

Threads
1,132,640
Messages
5,654,541
Members
418,139
Latest member
nimesh72

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top