Import af data - VBA / Macro

Hvis ikke der er flere overraskelser så kan denne kode gøre det. Lav output et tomt sted i samme ark og flyt det så bagefter.


Sub TransposeData()
  Dim EntireRange As Range
  Dim rgFirstcellIN As Range
  Dim rgFirstCellOUT As Range
  Dim rg1 As Range
  Dim x As Long
  Dim y As Long

  Set rgFirstcellIN = Application.InputBox("Select 1. cell for Datainput ", , , , , , , 8)
  Set rgFirstCellOUT = Application.InputBox("Select 1. cell for Dataoutput", , , , , , , 8)
  Set EntireRange = Range(rgFirstcellIN, Cells(65536, rgFirstcellIN.Column).End(xlUp))
  x = 2
  While x < EntireRange.Cells.Count
      Set rg1 = Range(Cells(x, 1), Cells(x, 1).End(xlDown))
      y = y + 1
      rgFirstCellOUT(y, 1).Resize(, 4) = Application.Transpose(rg1)
      If rg1.Cells.Count = 3 Then
        rgFirstCellOUT(y, 1).Offset(, 3) = rgFirstCellOUT(y, 1).Offset(, 2)
        rgFirstCellOUT(y, 1).Offset(, 2) = ""
      End If
      x = rg1.End(xlDown).Row + 2
  Wend
End Sub

Hej Bak
Den melder fejl i
Set EntireRange = Range(rgFirstcellIN, Cells(65536, rgFirstcellIN.Column).End(xlUp))

prøv at aktivere arket med dine adresser før du kører koden

en anden kode
Klik ind i den første celle med navn og kør makroen

Sub Makro1()
    Dim ADR As Variant, WS2 As Worksheet, RK As Range
    Set WS2 = Worksheets("Ark2")
    ActiveCell.Select
    Do
        ADR = Range(Range(ActiveCell.Address), Range(ActiveCell.Address).End(xlDown))
        Set RK = WS2.Range("A65536").End(xlUp).Offset(1, 0)
        Select Case UBound(ADR)
        Case 3
            WS2.Range(RK.Address) = ADR(1, 1)
            WS2.Range(RK.Address).Offset(0, 1) = ADR(2, 1)
            WS2.Range(RK.Address).Offset(0, 3) = ADR(3, 1)
        Case 4
            WS2.Range(RK.Address) = ADR(1, 1)
            WS2.Range(RK.Address).Offset(0, 1) = ADR(2, 1)
            WS2.Range(RK.Address).Offset(0, 2) = ADR(3, 1)
            WS2.Range(RK.Address).Offset(0, 3) = ADR(4, 1)
        End Select

        If IsEmpty(ADR(1, 1)) Then Exit Sub
        ActiveCell.Offset(UBound(ADR) + 1, 0).Select
    Loop
    Set WS2 = Nothing
    Set RK = Nothing
End Sub

Excelent - tak, jeg prøvede at samle datane til et andet ark.

Bak - tak for hjælpen, det var lige præcis det jeg manglede, ligger du et svar.

Kabbak - din fungere lige så godt, men point til bak, da hans kom først, samt virkede.

Kabbak, jeg brugte din, modificere den lidt, så den samtidigt transpornere datane.

I har begge fortjent lidt point, venligst svar begge så i kan dele

Jeg takker for alt jeres hjælp.

et svar ;-))

et til :-)