I am trying to make VBA to copy data and paste to matching worksheet name.

1. "Setting" Worksheet will have all mixed data of item types.
2. With VBA, copy & paste values on A & D columns to matching worksheet name.
3. VBA code will go through entire A7 -> lastrow

worksheet name is based on the item types.

---

Right now, I am stuck on this part - setting supplier as dynamic worksheet

Below is the issue area: "out of range"

For i = 7 To lastrow1
    'setting spl as the value of the item type
    spl = Cells(i, "A").Value
    'setting supplier as the worksheet name
    Set supplier = Sheets(spl)

---

Below is the entire VBA code: I have found an existing code, and had been tweaking to fit my usage.

Sub Copy_Data()
Dim lastrow1 As Long, i As Long, auxRow As Long, offsetRow As Long
Dim spl As String
Dim supplier As Worksheet

Set ws = Sheets("SETTING")
lastrow1 = ws.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

For i = 7 To lastrow1
    'setting spl as the value of the item type
    spl = Cells(i, "A").Value
    'setting supplier as the worksheet name
    Set supplier = Sheets(spl)
            
        auxRow = supplier.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        If auxRow > 1 Then auxRow = auxRow   1
        If auxRow = 1 Then auxRow = offsetRow
        
        supplier.Cells(auxRow, "A") = ws.Cells(i, "A")
        supplier.Cells(auxRow, "B") = ws.Cells(i, "D")
       
    Next i
End Sub

Thank you all in an advance.

I have tried to define the worksheet to have dynamic value - based on item type on column A.

But keep receiving 'out of range' when setting the worksheet.

CodePudding user response：

"out of range" because you are opening one sheet from the list. you need to open setting sheet when you run this code.

Another thing don't use Find function

ws.Columns("A").Find("*", searchorder:=xlByRows, earchdirection:=xlPrevious).Row

because returns either of the following outcomes:

If a match is found, the function returns the first cell where the value is located.

If a match is not found, the function returns nothing.

That's will give you error because you define lastrow1 and auxRow as long instead use this

lastrow1 = ws.Range("A" & Rows.Count).End(xlUp).Row

Try to use this code

Sub Copy_Data()
  Dim lastrow1 As Long, i As Long, auxRow As Long, offsetRow As Long
  Dim spl As String
  Dim supplier As Worksheet
  Dim ws As Worksheet

  Set ws = Sheets("SETTING")
  lastrow1 = ws.Range("A" & Rows.Count).End(xlUp).Row

For i = 7 To lastrow1
    'setting spl as the value of the item type
    spl = Cells(i, "A").Value
    'setting supplier as the worksheet name
    Set supplier = Sheets(spl)
    
    auxRow = supplier.Range("A" & Rows.Count).End(xlUp).Row   1
    
    supplier.Cells(auxRow, "A") = ws.Cells(i, "A")
    supplier.Cells(auxRow, "B") = ws.Cells(i, "D")
       
   Next i
End Sub

CodePudding user response：

Please, test the next code. If follows the scenario I tried describing in my above comment: place the range to be processed in an array, iterate it and place the necessary data in the dictionary, then drop the processed result in each appropriate sheet. Working only in memory, until dropping the processed result makes it very fast, even for large data:

Sub distributeIssues()
  Dim shS As Worksheet, lastR As Long, wb As Workbook, arr, arrIt, arrFin, i As Long
  Dim key, dict As Object
  
  Set wb = ThisWorkbooks
  Set shS = wb.Sheets("SETTING")
  lastR = shS.Range("A" & shS.rows.count).End(xlUp).row 'last row
  
  arr = shS.Range("A7:D" & lastR).Value2 'place the range in an array for faster iteration/processing
  
  'place the range to be processed in dictionary:
  Set dict = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(arr)  'iterate between the array rows
        If Not dict.Exists(arr(i, 1)) Then        'if key does not exist
            dict.Add arr(i, 1), Array(arr(i, 4))  'create it and place the value in D:D as array item
        Else
            arrIt = dict(arr(i, 1))               'place the item content in an array
            ReDim Preserve arrIt(UBound(arrIt)   1) 'extend the array with an element
            arrIt(UBound(arrIt)) = arr(i, 4)      'place value from D:D in the last element
            dict(arr(i, 1)) = arrIt               'place back the array as dictionary item
        End If
  Next i
  Stop
  'drop the necessary value in the appropriate sheet:
  Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
   For Each key In dict
        With wb.Worksheets(key).Range("B9").Resize(UBound(dict(key))   1, 1)
              .Value = Application.Transpose(dict(key))
              .Offset(, -1).Value = key
        End With
   Next key
  Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
  
  MsgBox "Ready..."
End Sub

Please, send some feedback after testing it.

If something not clear enough, do not hesitate to ask for clarifications.

The items can be in any order. No necessary to be sorted...