Change hard coded destination of data transfer to soft coded

AV_Geek

New Member
Joined
Jan 23, 2022
Messages
15
Office Version
  1. 365
Platform
  1. MacOS
Hi Everyone: I have another one I could use help with please.

I have Data that I want to extract and copy into a Grid. In one of the columns will be what I call the ID, and the other is the location. There are several grids on my worksheet and some of the IDs may be repeated.

In the below example, “154” is my Fleet, and “HNL, MAJ, PNI, TKK, and GUM” are my locations.

The extraction of data from my source is working well and the code works great, however the destination of my data is in hard coded cells. I have over 300 Fleets and manually changing the hard coded destination cells is going to be a problem, since the cell locations change as we add or remove IDs. This is only part of a larger macro.

VBA Code:
 'HNL

    Workbooks("154.xlsx").Activate
    Worksheets("TrainStatus").Activate

Application.ScreenUpdating = False

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
    If InStr(Cells(i, "A"), "HNL") Then
        Cells(i, "N").Copy
    End If
Next
Application.ScreenUpdating = True
    Workbooks("Monthly STATS.xlsm").Activate
    secondWorksheet.Activate
    ActiveSheet.Range("K6").Select
    On Error Resume Next
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

My goal is to change the destination to be soft coded to the cell where the Fleets intersects with the location. In this small example, I want the extracted data in the cell where, where 154 (in a vertical column) meets HNL (in a horizontal row).

There are 2 possible challenges:

1. There are cases where the Fleet will be duplicated. I have 2 possible solutions to that. Either A. the code places it into the first one and I link them (cellB=cellA), or they can be coded to enter in both rows. Only one of the two rows will be visible in the final presentation.
2. The Fleets aren’t always in the same column, and in some rows there are 2 Fleets.

I have included an image of a sample sheet that I will be placing my data into, and the full Macro that I’m working with. Any help would be appreciated.

Here is the full code right now for Fleet 154. Any help will be appreciated. Thanks in advance.


VBA Code:
Sub Fleet154()

Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
    Workbooks("154.xlsx").Activate
    RunIslandHopperWB
   A60minute_tolerence
ActiveSheet.Range("S3").Select
    Selection.Copy

'Division Delay

Dim i As Long
Dim Lastrow As Long
Dim firstWorksheet As Worksheet
Dim secondWorksheet As Worksheet

With ThisWorkbook
    Set firstWorksheet = .Sheets(Format(.Worksheets("00").Range("L2").Value, "00"))
    Set secondWorksheet = .Sheets(.Worksheets("00").Range("L4").Value)
End With

firstWorksheet.Activate
Lastrow = Cells(Rows.Count, "G").End(xlUp).Row

For i = 1 To Lastrow
    If InStr(Cells(i, "G"), "154") Then
        Cells(i, "H").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    End If
Next

Application.ScreenUpdating = True


'HNL

    Workbooks("154.xlsx").Activate
    Worksheets("TrainStatus").Activate
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
    If InStr(Cells(i, "A"), "HNL") Then
        Cells(i, "N").Copy
    End If
Next
Application.ScreenUpdating = True
    Workbooks("Monthly STATS.xlsm").Activate
    secondWorksheet.Activate
    ActiveSheet.Range("K6").Select
    On Error Resume Next
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

'MAJ

    Workbooks("154.xlsx").Activate
    Worksheets("TrainStatus").Activate
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
    If InStr(Cells(i, "A"), "MAJ") Then
        Cells(i, "N").Copy
    End If
Next
Application.ScreenUpdating = True
    Workbooks("Monthly STATS.xlsm").Activate
    secondWorksheet.Activate
    ActiveSheet.Range("L6").Select
    On Error Resume Next
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


'PNI

    Workbooks("154.xlsx").Activate
    Worksheets("TrainStatus").Activate
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
    If InStr(Cells(i, "A"), "PNI") Then
        Cells(i, "N").Copy
    End If
Next
Application.ScreenUpdating = True
    Workbooks("Monthly STATS.xlsm").Activate
    secondWorksheet.Activate
    ActiveSheet.Range("M6").Select
    On Error Resume Next
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


'TKK

    Workbooks("154.xlsx").Activate
    Worksheets("TrainStatus").Activate
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
    If InStr(Cells(i, "A"), "TKK") Then
        Cells(i, "N").Copy
    End If
Next
Application.ScreenUpdating = True
    Workbooks("Monthly STATS.xlsm").Activate
    secondWorksheet.Activate
    ActiveSheet.Range("N6").Select
        On Error Resume Next
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False   


'GUM

    Workbooks("154.xlsx").Activate
    Worksheets("TrainStatus").Activate
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
    If InStr(Cells(i, "A"), "GUM") Then
        Cells(i, "N").Copy
    End If
Next
Application.ScreenUpdating = True
    Workbooks("Monthly STATS.xlsm").Activate
    secondWorksheet.Activate
    ActiveSheet.Range("O6").Select
        On Error Resume Next
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

Call sourceSheet.Activate

End Sub
 

Attachments

  • Screen Shot 2022-05-02 at 1.30.11 AM 2.png
    Screen Shot 2022-05-02 at 1.30.11 AM 2.png
    173 KB · Views: 11

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

AV_Geek

New Member
Joined
Jan 23, 2022
Messages
15
Office Version
  1. 365
Platform
  1. MacOS
Does anyone have any ideas as to how to do this?
 

Forum statistics

Threads
1,176,504
Messages
5,903,431
Members
435,029
Latest member
excelvbanoob420

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