Kopieren van cellen naar ander tabblad

Dokman · 5 jun 2023

Hallo,

ik ben en formulier aan het maken waar mee we waarders kunnen vergelijken met elkaar. Alleen nu moet alles nog met de hand maar zou dat liever automatisch willen hebben.
Zal en kleine uitleg geven van wat ik nu gemaakt heb.

Ik kopiëren en lijst met nummers uit en website. En plakken deze in Excel met de volgende VBA-code.

ActiveSheet.Range("G2").Select
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True

Deze code wordt ook herhaalt op L2 Q2 V2 en AA2
Hij gaat dan vergelijken met A2 B2 C3 en D4 of er dubbelen getallen tussen zitten. Zodat wij kunnen zien welke
onderdelen we missen. Dit welke allemaal goed.

Maar nu wil ik het iets meer uitbreiden.
Wat ik zou willen is dat ik en button heb waar mee ik en bestand kan inlezen (.TXT) en dat deze
op en apart Tabblad wordt gezet. en dat hij dan sommige gegevens er uit haalt en deze kopieert naar
A2 B2 C3 en D4.

De tekst die ik dan ga inlezen is dit

(PROGRAM-VERSION=1)
(RUN-TIME=00-00-00)
(CUTTING-TIME=00-00-00)
(AUX-TIME=00-00-00)
(SECURITY-CLASS=0)
(PROGRAM-TYPE=0)
(PROGRAM-CLASS=0)

(P-START)
(P5002)
(P5003)
(P5009)
(P-END)

(T-START)
(10231067)(00-01-00)(VHM-BOOR + VERZ. 8 MM )
(10231075)(00-01-00)(VHM-BOOR + VERZ. 8.5 MM )
(10231076)(00-01-00)(VHM-BOOR 6.8 MM )
(11331058)(00-01-00)(WP-VOLBOOR WALTER 16.5 MM )
(11331062)(00-01-00)(WP-VOLBOOR WALTER 29.5 MM )
(12231026)(00-01-00)(KSEM-BOOR 25.05 MM )
(12231074)(00-01-00)(KSEM-BOOR 21 MM )
(13031007)(00-01-00)(HSS-VERZINKER 25 MM )
(13331005)(00-01-00)(WP-AFBRAMER 86 MM )
(13331007)(00-01-00)(WP-AFBRAMER 80-90 MM )
(14131057)(00-01-00)(TAP M18X1.5 )
(14131060)(00-01-00)(TAP INWENDIGE KOELING M8 )
(16331016)(00-01-00)(DRIESNIJDER 90 MM )
(16331058)(00-01-00)(DRIESNIJDER 86 MM )
(T-END)
en de tekst gaat hier onder nog verder. soms wel tot 10 A4tjes.

Het gaat dan om de getallen die tussen de () staan 11331062,
die zouden dan naar G2 L2 Q2 V2 en AA2 moeten gekopieerd worden.
het gaat alleen om de gegevens die tussen T-START en T-END staan.
de lijst kan van lengte verschillen. korter of langer.

De hele cell zou ook gekopieerd mogen worden naar het andere tabblad.

Al vast bedankt.

SjonR · 5 jun 2023

plaats aub een voorbeeldbestandje.

Dokman · 6 jun 2023

Hoi,

Ik heb en bestand toegevoegd. In het bestand zelf heb ik ook en uitleg gegeven waar ik op zoek naar ben.
Ik ben er al even mee bezig maar kan het niet vinden. of het kan helemaal niet wat ik graag zou willen.

Alvast bedankt dat u er tijd en moeite in wilt steken.

Dokman · 7 jun 2023

ik heb al iets gevonden wat ik denk ik kan gebruiken met en kleine aanpassing.
Maar als ik deze code gebruikt dan plaats hij de tekst in Blad2 en dan in Cell A1 graag zou
ik deze in en andere cell bijvoorbeeld B9 willen hebben. Maar weet niet echt waar
ik en hoe ik dat moet veranderen in de code. Heb veel geprobeerd, maar krijg alleen fout meldingen.

Sub rowcopy()
Dim rij As Long
Dim n As Long
Dim src As Worksheet
Dim trg As Worksheet
Set src = Sheets("Blad1")
Set trg = Sheets("Blad2")

Application.ScreenUpdating = False
rij = trg.[A65536].End(xlUp).Row
For n = 1 To Blad1.[A65536].End(xlUp).Row
If Cells(n, "A").Value = "volbracht" Then
Range(Cells(n, "A"), Cells(n, "A")).Copy
trg.Cells(rij, "C").PasteSpecial
rij = rij + 1
End If
Next
End Sub

Zou iemand er naar kunnen kijken. Want volgens mijn gaat het fout bij
trg.Cells(rij, "C").PasteSpecial want verander ik de C in een andere letter dan
plakt hij het wel in C neer. Maar ik wil heb ook in een andere rij.

AD1957 · 7 jun 2023

Lijkt me verstandig om het bestand te plaatsen waarin je deze code gebruikt.

Dokman · 7 jun 2023

Hier onder het bestand.
ik word later in een ander bestand gemaakt, dit is nog en test.
Het echte bestand kan ik hier niet posten. Vandaar dit bestand.

Als ik nu op "Knop 1" druk dan zet hij het woord "Klaar" in Blad2 op Cell C en rij 1
maar ik wil dat hij hem op Rij 2 of ander nummer zet.

AD1957 · 7 jun 2023

zo?

Code:

Sub rowcopy()
Dim rij As Long
Dim n As Long
Application.ScreenUpdating = False
rij = Sheets("Blad2").Range("C" & Rows.Count).End(xlUp).Offset(1).Row 'offset(1)= 1 rij verder
MsgBox rij
For n = 1 To Sheets("Blad1").Range("A" & Rows.Count).End(xlUp).Row
    If Cells(n, 1).Value = "Klaar" Then
        Sheets("Blad2").Cells(rij, 3) = Cells(n, 1)
        rij = rij + 1
    End If
Next
End Sub

Een goed gelijkend voorbeeldbestand met dummy gegevens kun je altijd posten.

Dokman · 7 jun 2023

Dank je wel ben al en eind op weg. Zou je me nog met 1 ding kunnen helpen. Zal hier onder de code geven.

Ik heb 1 tabblad met 2 knoppen.

Knop1 ImportTextFile Met deze lees ik en tekst bestand in. En hij maakt en nieuw tabblad aan die Kees heet.
In dat bestand staat zulke tekst.

(P-START)
(P5001)
(P5002)
(P-END)

(T-START)
(10231034)(00-01-00)(VHM-BOOR + VERZ. 10.5 MM )
(10231064)(00-01-00)(VHM-PILOTBOOR + VERLENGSTUK 6 MM )
(10231065)(00-01-00)(VHM-BOOR L=25XD 6 MM )
(T-END)

G0G80G90G52X0Y0Z0G49

G90G10L20P28X-84Y-286Z-723.5(B270 LINKS BOVEN)
G90G10L20P29X-70Y-592Z-723.5(B270 LINKS MIDDEN)
G90G10L20P30X-37.5Y-780Z-714.5(B270 LINKS ONDER)

En nog meer er onder.

Druk ik dan op de 2e knop rowcopy dan moet hij de zinnen dus cellen waar dit in voor komt 00-01-00 verplaatsen naar het tabblad waar de buttons staan.
Ik krijg wel voor elkaar dat hij die gegevens uit Blad1 haalt. Maar krijg het niet voor elkaar dat hij het uit het Blad "Kees" haalt.

Code die ik nu gebruik

Sub rowcopy()
Dim rij As Long
Dim n As Long
Application.ScreenUpdating = False
rij = Sheets("Blad2").Range("C" & Rows.Count).End(xlUp).Offset(1).Row 'offset(1)= 1 rij verder
For n = 1 To Sheets("Blad1").Range("A" & Rows.Count).End(xlUp).Row
If Cells(n, 1).Value = "Klaar" Then
Sheets("Blad2").Cells(rij, 3) = Cells(n, 1)
rij = rij + 1
End If
Next
End Sub

Public Sub ImportTextFile()
Dim CurFile As Workbook
Dim NewSheet As Worksheet
Dim TextFile As Workbook
Dim OpenFiles() As Variant
Dim i As Integer
Set CurFile = ActiveWorkbook
OpenFiles = GetFiles()
Application.ScreenUpdating = True
For i = 1 To UBound(OpenFiles)
Set NewSheet = CurFile.Worksheets.Add
Set TextFile = Workbooks.Open(OpenFiles(i))
TextFile.Sheets(1).Range("A1").CurrentRegion.Copy Destination:=NewSheet.Range("A1")
NewSheet.Name = "Kees"
Application.CutCopyMode = False
TextFile.Close
Next i
Application.ScreenUpdating = True
End Sub

Public Function GetFiles() As Variant
GetFiles = Application.GetOpenFilename(Title:="Select File(s) to Import", MultiSelect:=True)
End Function

Al vast bedankt.

AD1957 · 7 jun 2023

Wat dacht je van:

Code:

Sheets("Blad1")

te veranderen in

Code:

Sheets("Kees")

p.s. zet de codes tussen codetags.

Dokman · 7 jun 2023

Dank u het is gelukt. Maar hoe kan ik zoeken naar bepaalde worden in regels.
Nu wil het alleen maar als het wordt alleen in een cell staat. Is het een zin dan pakt hij die cel niet.

[TABLE="width: 451"]
[TR]
[TD](10231034)(00-01-00)(VHM-BOOR + VERZ. 10.5 MM )[/TD]
[/TR]
[TR]
[TD](10231064)(00-01-00)(VHM-PILOTBOOR + VERLENGSTUK 6 MM )[/TD]
[/TR]
[/TABLE]

Deze twee cellen wil ik dan verplaatsen. Dus ik laat heb zoeken op 00-01-00 want die komt en de regels voor
die ik graag tussen mijn tekst wil uit kopiëren.

maar als ik de code heb en ik kijk nu waar Klaar staat moet ik dan * er voor en er achter zetten.
of iets anders..

Code:

If Cells(n, 1).Value = "Klaar" Then

Dokman · 7 jun 2023

Denk dat ik er maar mee stop. Werkt gewoon niet gaat telkens wel iets mis.
Mag ik u in ieder geval bedankt voor u hulp.

AD1957 · 7 jun 2023

Lees dit eens.
https://www.automateexcel.com/vba/instr-find-text/
p.s. er zijn ook nog andere opties.

Dokman · 7 jun 2023

Bedankt zal er morgen eens na kijken. Ik ben er voor vandaag wel en beetje klaar mee.
Bijna hele dag mee bezig geweest. En heeft niets geholpen.

AD1957 · 7 jun 2023

Hier een voorbeeldje hoe het ook kan.
Nogmaals: Maak een goed gelijkend voorbeeldbestand, dan zien de helpers hier sneller waar het fout gaat.

En...... niet te snel de moed opgeven.

Dokman · 8 jun 2023

Goedemorgen, Ben al weer rond 5 uur aan het rommelen met het bestand.
Maar krijg het niet helemaal voor elkaar zou u er nog een keer naar kunnen kijken.

Want om 5 uur heb ik al weekend.

Ik heb 2 bestanden toegevoegd.
Het Excel bestand. En een bestand die wij dan altijd inlezen. dit bestand kan altijd en andere naam hebben.

Al vast bedankt.

AD1957 · 8 jun 2023

Aangezien je om 5 uur weekend hebt heb ik mijn weekend maar even opgeofferd.:shocked:

Code:

Sub Kopie()

With Sheets("Prog")
        Set c = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Find("(T-START)")
        Set cc = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Find("(T-END)")
        i = c.Row + 1
        ii = cc.Row - 1
        
        rij = 2
        
        For n = i To ii
             Sheets("Blad1").Cells(rij, "H") = Mid(.Cells(n, 1), 2, 8)
             Sheets("Blad1").Cells(rij, "M") = Mid(.Cells(n, 1), 2, 8)
             Sheets("Blad1").Cells(rij, "R") = Mid(.Cells(n, 1), 2, 8)
             Sheets("Blad1").Cells(rij, "W") = Mid(.Cells(n, 1), 2, 8)
             Sheets("Blad1").Cells(rij, "AB") = Mid(.Cells(n, 1), 2, 8)
             rij = rij + 1
        Next
    
        Application.DisplayAlerts = False
        .Delete 'verwijder Blad Prog
        Application.DisplayAlerts = True
    
       
End With
End Sub

en rode coderegel toevoegen.

Code:

Public Sub ImportTextFile()
    Dim CurFile As Workbook
    Dim NewSheet As Worksheet
    Dim TextFile As Workbook
    Dim OpenFiles() As Variant
    Dim i As Integer
    Set CurFile = ActiveWorkbook
    OpenFiles = GetFiles()
    Application.ScreenUpdating = False
    For i = 1 To UBound(OpenFiles)
        Set NewSheet = CurFile.Worksheets.Add
        Set TextFile = Workbooks.Open(OpenFiles(i))
        TextFile.Sheets(1).Range("A1").CurrentRegion.Copy Destination:=NewSheet.Range("A1")
        NewSheet.Name = "Prog"
        Application.CutCopyMode = False
        TextFile.Close
    Next i
    
    [COLOR="#FF0000"][B]Kopie[/B][/COLOR]
    
    Application.ScreenUpdating = True
End Sub

Lees dit eens goed door.https://www.helpmij.nl/forum/announcement.php?f=5

Dokman · 8 jun 2023

Mag ik u Bedanken en een prettig weekend wensen.

Het werkt nu zonder u was ik nog wel even bezig geweest. :thumb:

AD1957 · 8 jun 2023

nog een optie.

Code:

Sub Kopie_1()

With Sheets("Prog")
        Set c = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Find("(T-START)")
        Set cc = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Find("(T-END)")
        i = c.Row + 1
        ii = cc.Row - 1
        
       For Each ct In .Range(.Cells(i, 1), .Cells(ii, 1))
        ct.Value = Mid(ct, 2, 8)
       Next
       
       For j = 8 To 28 Step 5
        .Range(.Cells(i, 1), .Cells(ii, 1)).Copy Sheets("Blad1").Cells(2, j)
       Next
       
    
       Application.DisplayAlerts = False
       .Delete 'verwijder Blad Prog
       Application.DisplayAlerts = True
    
       
End With
End Sub

Dokman · 13 jun 2023

bedankt, hou het toch bij de eerst optie.

Mag ik u bedankt.

AD1957 · 13 jun 2023

Zet de vraag dan even als "OPGELOST" (In je openingsvraag aan de rechterkant.)

Kopieren van cellen naar ander tabblad

Gebruiker

Verenigingslid

Gebruiker

Bijlagen

Gebruiker

Verenigingslid

Gebruiker

Bijlagen

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Bijlagen

Gebruiker

Bijlagen

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Wij waarderen jouw privacy