Existing VBA enhancement

[ItalianPlatinum]

Hi - I have an existing VBA that was provided to me by someone here on the site, it works great. I have one change required that is resulting in this VBA to no longer be of use. Is someone able to help?

Essentially previously all the data was transferred over with columns next to each other now the destination path is changing where columns are no longer all next to each other so for example:

Column A to Column B
Column G to Column D
Column L to Column F

    Dim UsdRws As Long
    Dim FilePath As String
    Dim TestStr As String
    Dim FoundFile As Boolean
    Dim rws As Long
    Dim bottomrow, lastblank As Long
    Dim lr As Long
    Dim vCols As Variant, vRows As Variant
    Dim i As Long, k As Long
    Dim ErrMsg As String
    Dim ST As Workbook
    Dim wbNCOMP As Workbook
    Dim wsComp As Worksheet, wsComp1 As Worksheet, wsDIST As Worksheet, wsDIST1 As Worksheet, wsDV As Worksheet, wsDT As Worksheet
    Dim wb As Excel.Workbook
    
'set shortcut for with sheets
With ThisWorkbook
  Set wsComp = .Sheets("Compare")
  Set wsDIST = .Sheets("Periodic")
  Set wsDV = .Sheets("NAS D")
  Set wsDT = .Sheets("NAS DT")
End With
   
'set shortcut for sheet w/o WITH & ThisWorkbook
Set wsComp1 = Sheets("Compare")
Set wsDIST1 = Sheets("Periodic")
          
'transfer data over to Compare tab
  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With wsDIST
    With .Range("A1:K" & .Range("I" & rows.count).End(xlUp).row)
        If .rows.count > 2 Then
            vRows = Application.Index(.Cells, Evaluate("row(1:" & .rows.count & ")"), Array(9, 3))
            For i = 3 To UBound(vRows)
                If Len(vRows(i, 1)) > 0 And UCase(vRows(i, 2)) = "INCM" Then
                    k = k + 1
                    vRows(k, 1) = i
        End If
      Next i
      wsComp.Range("A13").Resize(k, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)
      Else
        MsgBox "No data to transfer"
      End If
    End With
  End With

 

[BSALV]

this is the most important line in that macro, so this one has to be adapted to the new situation.
But you want to copy now in 3 non-contigious ranges ??

 vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order

 

[ItalianPlatinum]

Yea so that like is grabbing what rows do i want to transfer over and when you transfer over it is just placing it in this line

With .Range("A1:K" & .Range("I" & rows.count).End(xlUp).row)

so yes to answer you it wont be continuous anymore and may change again at a future date so having it easily amendable would be nice but not important trying to get over the short term issue now

 

[BSALV]

I wrote comments at the RHS of the macro, so that you can understand what's happening

Sub x()

     Dim UsdRws As Long
     Dim FilePath As String
     Dim TestStr As String
     Dim FoundFile As Boolean
     Dim rws   As Long
     Dim bottomrow, lastblank As Long
     Dim lr    As Long
     Dim vCols As Variant, vRows As Variant
     Dim i As Long, k As Long
     Dim ErrMsg As String
     Dim ST    As Workbook
     Dim wbNCOMP As Workbook
     Dim wsComp As Worksheet, wsComp1 As Worksheet, wsDIST As Worksheet, wsDIST1 As Worksheet, wsDV As Worksheet, wsDT As Worksheet
     Dim wb    As Excel.Workbook

     'set shortcut for with sheets
     With ThisWorkbook
          Set wsComp = .Sheets("Compare")
          Set wsDIST = .Sheets("Periodic")
          Set wsDV = .Sheets("NAS D")
          Set wsDT = .Sheets("NAS DT")
     End With

     'set shortcut for sheet w/o WITH & ThisWorkbook
     Set wsComp1 = Sheets("Compare")
     Set wsDIST1 = Sheets("Periodic")

     'transfer data over to Compare tab
     vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)           '<- Columns of interest in specified order
     With wsDIST
          With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)     'a range 11 columns width and as many rows as the last used cell in column I
               If .Rows.Count > 2 Then
                    vRows = Application.Index(.Cells, Evaluate("row(1:" & .Rows.Count & ")"), Array(9, 3))     'read only the 9th and 3rd column = I & C to an array
                    For i = 3 To UBound(vRows)                  'start in the 3rd untill last row
                         If Len(vRows(i, 1)) > 0 And UCase(vRows(i, 2)) = "INCM" Then     'was in the sheet, the I not empty and the C="INCM" ?
                              k = k + 1                         'increment a pointer
                              vRows(k, 1) = i                   'set that in the 1st column of that array (meaning, this is a row that 'll be copied later
                         End If
                    Next i
                    
                    wsComp.Range("A13").Resize(k, 3).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(1, 9, 10)) 'copy 3 columns (1, 9 & 10 of the original) to A13 = 1st contigious range
                    wsComp.Range("E13").Resize(k, 5).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(11, 2, 3, 4, 5)) 'copy 5 columns  to E13 = 2nd contigious range
                   wsComp.Range("I13").Resize(k, 3).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(6, 7, 8)) 'copy 3 columns  to I13 = 3rd contigious range
                    
               Else
                    MsgBox "No data to transfer"
               End If
          End With
     End With
End Sub

What you want is happening in the 3 similar lines like this one

wsComp.Range("E13").Resize(k, 5).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(11, 2, 3, 4, 5)) 'copy 5 columns  to E13 = 2nd contigious range

in a 2nd range
* with E13 in the topleft corner
* you write 5 columns of the original data that started in the A-column of wsDist, so that's K, B, C, D and E
* and okay with I-column not empty + C-column="INCM"
The only thing you have to do now, add such a line and adjust the bold parts for each new range you want.
Do you understand ?

 

[ItalianPlatinum]

Thank you! I will test this out today and get back to you.

 

[ItalianPlatinum]

ok i cant get it to work. I have in calculation from C3:P data i need to move to sheet DA IA starting on B7 using the filter of IA that resides in row B in calculation tab

so calculation E3 to DA IA B7

ill stop there cause i fail at the first line saying out of memory

 .Range("B7").Resize(k, 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(3))  'copy 1 columns (1, 3, 5, 10 of the original) to A13 = 1st contigious range

'transfer data over to Compare tab
     vCols = Array(1, 3, 5, 14)           '<- Columns of interest in specified order
     With Sheets("Calculation")
          With .Range("C3:P" & .Range("A" & rows.count).End(xlUp).row)     'a range 14 columns width and as many rows as the last used cell in column I
               If .rows.count > 2 Then
                    vRows = Application.Index(.Cells, Evaluate("row(1:" & .rows.count & ")"), Array(14, 3))     'read only the 9th and 3rd column = I & C to an array
                    For i = 3 To UBound(vRows)                  'start in the 3rd untill last row
                         If Len(vRows(i, 1)) > 0 And UCase(vRows(i, 2)) = "IA" Then     'was in the sheet, the I not empty and the C="IA" ?
                              k = k + 1                         'increment a pointer
                              vRows(k, 1) = i                   'set that in the 1st column of that array (meaning, this is a row that 'll be copied later
                         End If
                    Next i
                    With Sheets("DA IA")
                        .Range("B7").Resize(k, 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(3))  'copy 1 columns (1, 3, 5, 10 of the original) to A13 = 1st contigious range
                        .Range("C7").Resize(k, 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(1)) 'copy 1 columns  to E13 = 2nd contigious range
                        .Range("F7").Resize(k, 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(5)) 'copy 1 columns  to I13 = 3rd contigious range
                        .Range("H7:G7").Resize(k, 2).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), Array(14)) 'copy 1 columns  to I13 = 3rd contigious range
                    End With
               Else
                    MsgBox "No data to transfer"
               End If
          End With
     End With