Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Makro für Wort in Zeile suchen und enstrechende Spalte in neues Arbeitsblatt kopieren

Frage Entwicklung VB for Applications

Mitglied: Zebras

Zebras (Level 1) - Jetzt verbinden

01.06.2014, aktualisiert 17:00 Uhr, 1777 Aufrufe, 4 Kommentare, 2 Danke

Hi, ich stehe vor folgendem Problem:
Ich habe eine Ansammlung von Daten die sortiert werden muss. Dabei muss die erste Zeile nach einer Bezeichnung durchsucht werden und 2 dazugehörige Spalten in ein neues Arbeitsblatt kopiert werden. Wenn es den gesuchten Eintrag nicht gibt, sollen die 2 Spalten in der geordenten Reihenfolge leer bleiben. So wie in den beigefügten Bildern gezeigt.
Ich hoffe das es nicht zu schwer umzusetzten ist, da ich selbst nicht viel Verständnis darüber besitze. Ich bin über jede Hilfe dankbar : )

Wie es aussehen soll, wenn es sortiert wurde:
653958e25725f57c04f4124de5a3bf70 - Klicke auf das Bild, um es zu vergrößern

Wie die Rohdaten vorliegen:
f5adb419a847a841628319c1261a8b7f - Klicke auf das Bild, um es zu vergrößern

Mitglied: rubberman
LÖSUNG 01.06.2014, aktualisiert um 17:00 Uhr
Hallo Zebras,

könnte so aussehen.
01.
Sub CopyData() 
02.
    Dim lCols As Long, lLastNum As Long, lFound As Long, i As Long, _ 
03.
        strLast As String, strCurrHead, _ 
04.
        wsCopy As Excel.Worksheet, wsPaste As Excel.Worksheet, _ 
05.
        rgCopyHead As Excel.Range, rgFound As Excel.Range 
06.
 
07.
    Const strConstHead = "Versuch_" 
08.
    Set wsCopy = ThisWorkbook.Worksheets("Tabelle3") 
09.
    Set wsPaste = ThisWorkbook.Worksheets("Tabelle2") 
10.
 
11.
    lCols = wsCopy.UsedRange.Columns.Count 
12.
    Set rgCopyHead = wsCopy.Range(wsCopy.Cells(1, 1), wsCopy.Cells(1, lCols)) 
13.
    strLast = wsCopy.Cells(1, lCols - 1) 
14.
    lLastNum = CLng(Mid(strLast, InStrRev(strLast, "_") + 1)) 
15.
 
16.
    For i = 1 To lLastNum 
17.
        strCurrHead = strConstHead & CStr(i) 
18.
        Set rgFound = rgCopyHead.Find(strCurrHead, , , xlWhole, , , True) 
19.
        If rgFound Is Nothing Then 
20.
            wsPaste.Cells(1, i * 2 - 1) = strCurrHead 
21.
            wsPaste.Cells(1, i * 2).ClearContents 
22.
        Else 
23.
            lFound = rgFound.Column 
24.
            wsCopy.Range(wsCopy.Columns(lFound), wsCopy.Columns(lFound + 1)).Copy 
25.
            wsPaste.Range(wsPaste.Columns(i * 2 - 1), wsPaste.Columns(i * 2)).PasteSpecial 
26.
            Application.CutCopyMode = False 
27.
        End If 
28.
    Next 
29.
End Sub
Ich habe als größte Versuchsnummer in der Kopfzeile die letzte in der zu kopierenden Tabelle angenommen. Keine Ahnung ob das so OK ist.

Grüße
rubberman
Bitte warten ..
Mitglied: Zebras
01.06.2014, aktualisiert um 17:17 Uhr
Vielen vielen Dank für deine schnelle Antwort. Und es ist fast exakt so wie ich es bräuchte :D Idealer wäre es, wenn nicht nach dem festen Wert "Versuch_" gesucht wird, sondern nach den Inhalten der 1. Reihe des Arbeitsblatt 2. - > Wie z.B. A1:"Lac-1-AAE-1.csv" ; C1: "Lac-1-AAE-2.csv" ; E1: "LAC-1-FoPi-1.csv" ; usw.
Beste Grüße Zebras
Bitte warten ..
Mitglied: rubberman
01.06.2014 um 17:54 Uhr
Hallo Zebras,

mir war nicht bewusst, dass die Überschriften in Tabelle2 bereits vollständig existieren.
Teste:
01.
Sub CopyData() 
02.
    Dim lColsCopy As Long, lColsPaste As Long, lFound As Long, i As Long, _ 
03.
        strCurrHead As String, _ 
04.
        wsCopy As Excel.Worksheet, wsPaste As Excel.Worksheet, _ 
05.
        rgCopyHead As Excel.Range, rgFound As Excel.Range 
06.
 
07.
    Set wsCopy = ThisWorkbook.Worksheets("Tabelle3") 
08.
    Set wsPaste = ThisWorkbook.Worksheets("Tabelle2") 
09.
 
10.
    lColsCopy = wsCopy.UsedRange.Columns.Count 
11.
    lColsPaste = wsPaste.UsedRange.Columns.Count 
12.
    Set rgCopyHead = wsCopy.Range(wsCopy.Cells(1, 1), wsCopy.Cells(1, lColsCopy)) 
13.
 
14.
    For i = 1 To lColsPaste Step 2 
15.
        strCurrHead = wsPaste.Cells(1, i) 
16.
        Set rgFound = rgCopyHead.Find(strCurrHead, , , xlWhole, , , True) 
17.
        If Not rgFound Is Nothing Then 
18.
            lFound = rgFound.Column 
19.
            wsCopy.Range(wsCopy.Columns(lFound), wsCopy.Columns(lFound + 1)).Copy 
20.
            wsPaste.Range(wsPaste.Columns(i), wsPaste.Columns(i + 1)).PasteSpecial 
21.
            Application.CutCopyMode = False 
22.
        End If 
23.
    Next 
24.
End Sub
Grüße
rubberman
Bitte warten ..
Mitglied: Zebras
01.06.2014 um 18:33 Uhr
Klappt perfekt. Tausend Dank : )
Bitte warten ..
Neuester Wissensbeitrag
Humor (lol)

Linkliste für Adventskalender

(3)

Information von nikoatit zum Thema Humor (lol) ...

Heiß diskutierte Inhalte
Windows Server
DHCP Server switchen (25)

Frage von M.Marz zum Thema Windows Server ...

SAN, NAS, DAS
gelöst HP-Proliant Microserver Betriebssystem (14)

Frage von Yannosch zum Thema SAN, NAS, DAS ...

Grafikkarten & Monitore
Win 10 Grafikkarte Crash von Software? (13)

Frage von Marabunta zum Thema Grafikkarten & Monitore ...

Windows 7
Verteillösung für IT-Raum benötigt (12)

Frage von TheM-Man zum Thema Windows 7 ...