CODEWITHSUNDEEP
excelvba
yellowlilly
yellowlilly

Reputation: 1

VBA: How do I include hyperlinks when transferring data to multiple spreadsheets?

I am creating a data organization system. I have created a sub that will import a spreadsheet full of data (sheet1), allow the user to categorize each entry to a specific department (Column L), and then distribute the data to a master spreadsheet (Cumlative-bydirectorate), and to the respective sub sheet based on the department categorization (Column L).

I'm having trouble keeping the hyperlinks present in column A when transferring to the various sheets. I'm not sure what to change to keep the hyperlinks in the transferred cells.

here is the code I'm using. It is only pasting the cell values, not the hyperlink embedded within the cell. Column A consists of numbers, but each number is associated with a unique hyperlink

Sub copyrows()

Dim wsMst As Worksheet
Dim wsDpt As Worksheet
Dim wsImp As Worksheet
Dim lSRow As Long
Dim lCol As Long
Dim lMRow As Long
Dim lDRow As Long

Set wsImp = Sheets("sheet1")
Set wsMst = Sheets("Cumulative-bydirectorate")

lSRow = 2

lMRow = WorksheetFunction.CountA(wsMst.Range("$A:$A")) + 1

Do Until wsImp.Cells(lSRow, 1) = ""

    Set wsDpt = Sheets(wsImp.Range("L" & lSRow).Value2)
    lDRow = WorksheetFunction.CountA(wsDpt.Range("$A:$A")) + 1

    For lCol = 1 To 12

        wsMst.Cells(lMRow, lCol) = wsImp.Cells(lSRow, lCol)
        wsDpt.Cells(lDRow, lCol) = wsImp.Cells(lSRow, lCol)

    Next lCol

    wsImp.Rows(lSRow).ClearContents

    lMRow = lMRow + 1
    lSRow = lSRow + 1

Loop
End Sub

Upvotes: 0

Views: 34

Answers (1)

Super Symmetry
Super Symmetry

Reputation: 2875

You can copy and paste the first cell (column A): [Not Tested]

Sub copyrows()

Dim wsMst As Worksheet
Dim wsDpt As Worksheet
Dim wsImp As Worksheet
Dim lSRow As Long
Dim lCol As Long
Dim lMRow As Long
Dim lDRow As Long

Set wsImp = Sheets("sheet1")
Set wsMst = Sheets("Cumulative-bydirectorate")

lSRow = 2

lMRow = WorksheetFunction.CountA(wsMst.Range("$A:$A")) + 1

Do Until wsImp.Cells(lSRow, 1) = ""

    Set wsDpt = Sheets(wsImp.Range("L" & lSRow).Value2)
    lDRow = WorksheetFunction.CountA(wsDpt.Range("$A:$A")) + 1

    wsImp.Cells(lSRow, 1).Copy Destination:=wsMst.Cells(lMRow, 1)
    wsImp.Cells(lSRow, 1).Copy Destination:=wsDpt.Cells(lDRow, 1)

    For lCol = 2 To 12

        wsMst.Cells(lMRow, lCol) = wsImp.Cells(lSRow, lCol)
        wsDpt.Cells(lDRow, lCol) = wsImp.Cells(lSRow, lCol)

    Next lCol    

    wsImp.Rows(lSRow).ClearContents

    lMRow = lMRow + 1
    lSRow = lSRow + 1

Loop
End Sub

Upvotes: 0

Related Questions