Indhente forsendelsesoplysninger

Har ikke tid, men du kunne lave en vba:

Transpose kolonne A indtil dublet.
Læs række 1, læg firmanavn 1 under "Firma"
Læs række 2, læg firmaadresse 1 under "Adresse"
Læs række 3, læg varelinje 1 under "Vare1"
Læs række 4, læg varelinje 2 under "Vare2"
indtil kolonne atter viser "Firma"
forfra...
osv.

Løsningen kunne være en VBA kode som denne:
NB, du skal angive 1. celle, navnet på første information og antal informationer mellem ******** linierne

Du kan evt. unlade 1. celle hvis du selv markerer øverste venstreste celle med data, og deaktiverer linien
Range("A1").Select
ved at sætte Appostrof (') foran
'Range("A1").Select

KODEN sættes ind i et modul:
Kør med F5 for at køre, eller F8 trin for trin

Hvis dette ikke giver mening, skriv lige igen!

Sub FindFirmaOplysningerOgPlacerPåNyFane()
' ANTAGELSER
' DER ER INGEN TOMME RÆKKER I DATAOMTÅDET
' DER ER "OVERSKRIFT" TIL ALLE RÆKKER MED FIRMAINFO
Dim lngRow As Long
Dim lngCol As Long
Dim lngTargetCol As Long
Dim lngTargetRow As Long
Dim intInfoCounter As Integer
Dim lngDataRows As Long
Dim strFørsteNavn As String
Dim intAntalOplysningerInclFirma As Integer
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
'*****************************************************
'**** OBS, UDFYLD DE 3 PARAMETRE HERUNDER  **********
'*****************************************************
' her skal adressen hvor data starter angives
Range("A1").Select
' Her angives antal oplysninger pr firma
intAntalOplysningerInclFirma = 3
' Her angives første overskrift navn
strFørsteNavn = "Firma"
'*****************************************************
lngDataRows = ActiveCell.CurrentRegion.Rows.Count
' opretter et nyt ark
Set wsSource = ActiveSheet
Set wsTarget = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wsSource.Activate
' klargør variabler
lngCol = ActiveCell.Column
lngRow = ActiveCell.Row
lngTargetRow = 2
lngTargetCol = 1
Do While Cells(lngRow, lngCol).Value <> ""
' find Firma overskrift
Do Until LCase(Cells(lngRow, lngCol).Value) = LCase(strFørsteNavn)
lngRow = lngRow + 1
If lngRow > lngDataRows Then
Exit Do
End If
Loop
If lngTargetRow = 2 Then
For intInfoCounter = 0 To intAntalOplysningerInclFirma - 1
' overskrifter
wsTarget.Cells(1, intInfoCounter + 1).Value = wsSource.Cells(lngRow + intInfoCounter, lngCol).Value
Next
End If
For intInfoCounter = 0 To intAntalOplysningerInclFirma - 1
wsTarget.Cells(lngTargetRow, lngTargetCol + intInfoCounter).Value = Cells(lngRow, lngCol + 1).Value
lngRow = lngRow + 1
DoEvents
Next
lngTargetRow = lngTargetRow + 1
Loop
wsTarget.Activate
MsgBox "Færdig"
End Sub

1000 tak store stygge. Virkelig imponerende :-)

Den antager der står firma som overskrift i alle. Det gør der dog ikke men det har jeg fundet en løsning på.

Igen mange mange tak :-)