Intereting Posts
Activer la feuille Excel dans VBA sans naviguer vers la feuille de travail
Si vous désactivez la macro sur le file excel, vous ne pouvez pas copyr une feuille d'un classur à l'autre
Correspondance des données de colonnes à partir de 2 feuilles de calcul non correspondantes, puis alignment automatique des données, ajout de lignes vierges au besoin
Perdre la frontière des cellules fusionnées lors de l'édition du file Excel avec openpyxl
Recréer une google spreadsheet QUERY () dans Excel
Objets incorrects dans le tableau croisé dynamic montrant datatables brutes
Chemins relatifs pour le file VBScript
Création automatique d'instances distinctes d'une class (Python – Excel / CSV)
Excel VBA La validation des données change de couleur lorsque les nombres sont situés
Valeurs moyennes à partir de dates spécifiques
Obtenir le nom et la valeur d'activecontrol à partir d'un formulaire multipages
Comment split cette string en colonne séparée dans la feuille de calcul?
Passer une string de CodeIgniter Controller à date_diff
locking de la feuille de calcul Excel qui a une macro
Comptez combien de gamme ne sont pas vierges ou dans la list
Copier chaque ligne dans un autre classur en fonction de la valeur de la première colonne
J'ai un classur où les détails d'un client sont connus dans un ordre connu exporté à partir d'un autre programme. Prénom dans la colonne B, nom de famille dans la colonne C et ainsi de suite. Il existe environ 20 colonnes avec différents détails et plusieurs lignes avec différents clients.
Je souhaite que ces détails soient exportés vers deux classurs différents.
Disons qu'il y a 3 classurs:
- coco pour les contacts où des détails vont être envoyés à partir de
- conduit à la vente et
- email pour courrier électronique livre de contact
Il existe déjà des lignes dans ces classurs, de sorte que les choses exscopes devraient aller à la dernière ligne.
- Conservez tous les numéros de téléphone mobile depuis les contacts Excel et Android
- Comment get le format de numéro droit dans la feuille Excel
- Outlook vba: Exporter le text en surbrillance vers un nouveau contact
Les colonnes de ces deux classurs sont dans un ordre totalement différent. Donc, par exemple, la cellule B4 devrait passer à la colonne C dans les pistes et à la colonne D dans le courrier électronique.
Cependant, je ne veux pas que tous les contacts soient destinés aux ouvrages, aux prospects et au courrier électronique. Avant chaque ligne de coco, il y a une list déroulante où l'user peut choisir si elle veut que les détails de cette ligne soient déplacés vers les prospects, les courriels ou les deux.
J'ai commencé à faire le code pour déplacer les colonnes une par une. De cette façon, il aurait été beaucoup plus simple. Cependant, j'ai réalisé que l'user devrait avoir la possibilité de choisir où la ligne doit être exscope, la logique n'est plus si simple pour moi.
Chaque ligne (et chaque cellule d'une ligne) doit être traitée une par une. Je suppose qu'il devrait y avoir deux loops nestedes qui traitent d'abord la rangée, puis les cellules à l'intérieur.
Voici ci-dessous où j'ai commencé. Je ne sais plus que ce n'est plus utilisable. J'ai également fait des expériences plus tard, donc ça pourrait sembler un peu désordonné, mais collez-le de toute façon.
Public lastrowcoco, lastrowleads, lastrowemail As Long Public shtcoco As Worksheet Public shtleads As Worksheet Public wkbname As Ssortingng Public wkbcoco As Workbook Public wkbleads As Workbook Public rngcoco As Range Public rowcoco As Range Public lc, ll, le, nc, nl, ne As Long Public Sub CopyCells() wkbname = ActiveWorkbook.Name Set wkbcoco = Workbooks(wkbname) With wkbcoco activesheet.Name = "Transfer" End With With wkbcoco lastrowcoco = Range("D" & Rows.Count).End(xlUp).row End With Call Copy("B", "D") lastrowcoco = Empty lastrowleads = Empty End Sub Sub Copy(c As Ssortingng, Optional le As Ssortingng, Optional e As Ssortingng) Set shtcoco = wkbcoco.Sheets("Transfer") shtcoco.Range(c & "2:" & c & lastrowcoco).Copy Set wkbleads = Workbooks.Open("U:\leads.xls") Set shtleads = wkbleads.Sheets("Leads") With shtleads lastrowleads = .cells(Rows.Count, "D").End(xlUp).row End With shtleads.Range(le & 1 + lastrowleads).PasteSpecial 'wkbleads.Close End Sub Merci d'avance, Joonas
Dim dest As Range Set dee = Application.InputBox(prompt:="enter destination cell ref ex sheet1!a1", Type:=8)
devrait le faire, bonne chance
Ok alors, voici ma résolution. J'aurais été un peu plus précis sur le problème et sur mes feuilles. Comme je l'ai dit, cela est loin d'être optimal car il y a une répétition inutile. J'ai d'abord essayé d'utiliser plus de sous-procédures, mais cela n'a pas fonctionné en raison d'un problème de déclaration. Probablement certaines variables ont été déclarées deux fois.
Mais ici, c'est de toute façon. J'ai supprimé des pièces trop identifiables.
Sub Copycat() Dim i As Long Dim rCount As Long Dim r As Range Dim today As Date Dim cell As Range Dim Msg As Variant If Range("A1") = "Transfer" Then Msg = MsgBox("It looks like the script is already executed." & Chr(10) & "Do you really want to execute it again?" & Chr(10) & Chr(10) & "It will add the new columns as double.", vbYesNo, "") If Msg = vbNo Then Exit Sub End If End If If Not Range("B1") = "FirstName" Then Msg = MsgBox("It looks like this sheet is not the right file" & Chr(10) & "Do you really want to execute the script?" & Chr(10) & Chr(10) & "Unsaved changes will be lost.", vbYesNo, "") If Msg = vbNo Then Exit Sub End If End If 'Add columns Range("I:T").Insert Shift:=xlToLeft 'Add/change subjects Range("A1") = "Transfer" Range("C1") = "Seller" Range("E1") = "" Range("G1") = "" Range("T1") = "" 'Add validation values Range("AO2") = "Product1" Range("AO3") = "Product2" 'Removed Range("AQ2") = "Both" Range("AQ3") = "Email" Range("AQ4") = "Leads" 'Removed Range("AU2") = "Prospect" Range("AU3") = "Competitor" Range("AU4") = "Partner" Range("AU5") = "Yes" With ActiveSheet rCount = .Cells(.Rows.Count, "D").End(xlUp).row 'rCount = ActiveSheet.Range(Rows.Count).End(xlUp).Row End With 'r = Range("J2:J" & rCount) For Each cell In Range("J2:J" & rCount) cell = Date Next For Each cell In Range("K2:K" & rCount) cell = "Email" Next For Each cell In Range("O2:O" & rCount) cell = "Prospect" Next For Each cell In Range("N2:N" & rCount) cell = "Glass" Next For Each cell In Range("C2:C" & rCount) cell = "RJ" Next With ActiveSheet.Range("Q2:Q" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AO$2:$AO$7" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("C2:C" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AV$2:$AV$4" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("O2:O" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AU$2:$AU$5" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("M2:M" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AP$2:$AP$12" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("A2:A" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AQ$2:$AQ$4" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("K2:K" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AR$2:$AR$7" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("N2:N" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AS$2:$AS$5" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("P2:P" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AT$2:$AT$7" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("N2:N" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AS$2:$AS$5" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With With ActiveSheet.Range("A2:A" & rCount).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$AQ$2:$AQ$4" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = False End With ActiveSheet.Buttons.Add(500, 300, 105, 25).Select Selection.OnAction = "PERSONAL.XLSB!Copycat2" With Selection.Font .Name = "Submit" .Size = 15 End With Selection.Characters.Text = "Submit" Range("F25") = "When all the details are filled in, press the button:" Cells(1, 1).Select End Sub Sub Copycat2() Dim lastrowcoco, lastrowleads, lastrowemail As Long Dim shtcoco, shtleads, shtemail As Worksheet Dim wkbname, shtname As Ssortingng Dim wkbcoco, wkbleads, wkbemail As Workbook Application.ScreenUpdating = False If Not ActiveSheet.Cells(1, 2).Value = "FirstName" Then MsgBox ("It looks like the sheet where you are running the script is not " & Chr(10) & "from the right one. Check that you have the right sheet active.") Exit Sub End If Dim currentRow As Integer Dim b, v, i, rCount, rCounte As Integer rCount = 0 rCounte = 0 wkbname = ActiveWorkbook.Name Set wkbcoco = Workbooks(wkbname) shtname = ActiveSheet.Name Set shtcoco = wkbcoco.Worksheets(shtname) Set wkbleads = Workbooks.Open("saleleads file.xls") Set shtleads = wkbleads.Sheets("Leads") Set wkbemail = Workbooks.Open("G:\email list file.xls") Set shtemail = wkbemail.Sheets("Sheet1") With shtleads lastrowleads = .Cells(Rows.Count, "D").End(xlUp).row + 1 End With With shtcoco lastrowcoco = .Cells(Rows.Count, "D").End(xlUp).row End With With shtemail lastrowemail = .Cells(Rows.Count, "D").End(xlUp).row + 1 End With For i = 2 To lastrowcoco If shtcoco.Cells(i, 1).Value = "Leads" Then t = 1 ElseIf shtcoco.Cells(i, 1).Value = "Email" Then t = 2 ElseIf shtcoco.Cells(i, 1).Value = "Both" Then t = 3 End If Select Case t Case Is = 1 For b = 1 To 33 Step 1 shtcoco.Cells(i, b).Copy Select Case b Case Is = 2 shtleads.Cells(lastrowleads + rCount, 22).PasteSpecial xlPasteValues Case Is = 4 shtleads.Cells(lastrowleads + rCount, 23).PasteSpecial xlPasteValues Case Is = 6 shtleads.Cells(lastrowleads + rCount, 2).PasteSpecial xlPasteValues Case Is = 8 shtleads.Cells(lastrowleads + rCount, 24).PasteSpecial xlPasteValues Case Is = 9 shtleads.Cells(lastrowleads + rCount, 25).PasteSpecial xlPasteValues Case Is = 10 shtleads.Cells(lastrowleads + rCount, 4).PasteSpecial xlPasteValues Case Is = 11 shtleads.Cells(lastrowleads + rCount, 5).PasteSpecial xlPasteValues Case Is = 12 shtleads.Cells(lastrowleads + rCount, 7).PasteSpecial xlPasteValues Case Is = 13 shtleads.Cells(lastrowleads + rCount, 8).PasteSpecial xlPasteValues Case Is = 14 shtleads.Cells(lastrowleads + rCount, 9).PasteSpecial xlPasteValues Case Is = 15 shtleads.Cells(lastrowleads + rCount, 10).PasteSpecial xlPasteValues Case Is = 16 shtleads.Cells(lastrowleads + rCount, 11).PasteSpecial xlPasteValues Case Is = 17 End If Case Is = 18 shtleads.Cells(lastrowleads + rCount, 29).PasteSpecial xlPasteValues Case Is = 19 shtleads.Cells(lastrowleads + rCount, 30).PasteSpecial xlPasteValues Case Is = 22 shtleads.Cells(lastrowleads + rCount, 31).PasteSpecial xlPasteValues Case Is = 23 shtleads.Cells(lastrowleads + rCount, 32).PasteSpecial xlPasteValues Case Is = 24 Case Is = 25 shtleads.Cells(lastrowleads + rCount, 33).PasteSpecial xlPasteValues shtleads.Cells(lastrowleads + rCount, 3).PasteSpecial xlPasteValues Case Is = 29 shtleads.Cells(lastrowleads + rCount, 27).PasteSpecial xlPasteValues Case Is = 28 shtleads.Cells(lastrowleads + rCount, 26).PasteSpecial xlPasteValues Case Is = 30 shtleads.Cells(lastrowleads + rCount, 20).PasteSpecial xlPasteValues Case Is = 31 shtleads.Cells(lastrowleads + rCount, 28).PasteSpecial xlPasteValues Case Is = 32 If shtcoco.Cells(i, b).Value = "M" Then shtleads.Cells(lastrowleads + rCount, 21).Value = "Mr." ElseIf shtemail.Cells(i, b).Value = "F" Then shtleads.Cells(lastrowleads + rCount, 21).Value = "Ms." Else: shtleads.Cells(lastrowleads + rCount, 21).PasteSpecial xlPasteValues End If End Select Next b Case Is = 2 For b = 1 To 33 Step 1 shtcoco.Cells(i, b).Copy Select Case b Case Is = 2 shtemail.Cells(lastrowemail + rCounte, 4).PasteSpecial xlPasteValues Case Is = 3 shtemail.Cells(lastrowemail + rCounte, 13).PasteSpecial xlPasteValues Case Is = 4 shtemail.Cells(lastrowemail + rCounte, 5).PasteSpecial xlPasteValues Case Is = 6 shtemail.Cells(lastrowemail + rCounte, 6).PasteSpecial xlPasteValues Case Is = 9 shtemail.Cells(lastrowemail + rCounte, 16).PasteSpecial xlPasteValues Case Is = 10 shtemail.Cells(lastrowemail + rCounte, 14).PasteSpecial xlPasteValues Case Is = 11 shtemail.Cells(lastrowemail + rCounte, 15).PasteSpecial xlPasteValues Case Is = 13 shtemail.Cells(lastrowemail + rCounte, 9).PasteSpecial xlPasteValues Case Is = 15 shtemail.Cells(lastrowemail + rCounte, 8).PasteSpecial xlPasteValues Case Is = 17 shtemail.Cells(lastrowemail + rCounte, 10).PasteSpecial xlPasteValues Case Is = 30 shtemail.Cells(lastrowemail + rCounte, 2).PasteSpecial xlPasteValues Case Is = 25 shtemail.Cells(lastrowemail + rCounte, 7).PasteSpecial xlPasteValues Case Is = 32 If shtcoco.Cells(i, b).Value = "M" Then shtemail.Cells(lastrowemail + rCounte, 3).Value = "Mr." ElseIf shtemail.Cells(i, b).Value = "F" Then shtemail.Cells(lastrowemail + rCounte, 3).Value = "Ms." Else: shtemail.Cells(lastrowemail + rCounte, 3).PasteSpecial xlPasteValues End If End Select Next b Case Is = 3 For b = 1 To 33 Step 1 shtcoco.Cells(i, b).Copy Select Case b Case Is = 2 shtleads.Cells(lastrowleads + rCount, 22).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 4).PasteSpecial xlPasteValues Case Is = 3 shtemail.Cells(lastrowemail + rCounte, 13).PasteSpecial xlPasteValues Case Is = 4 shtleads.Cells(lastrowleads + rCount, 23).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 5).PasteSpecial xlPasteValues Case Is = 6 shtleads.Cells(lastrowleads + rCount, 2).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 6).PasteSpecial xlPasteValues Case Is = 8 shtleads.Cells(lastrowleads + rCount, 24).PasteSpecial xlPasteValues Case Is = 9 shtleads.Cells(lastrowleads + rCount, 25).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 16).PasteSpecial xlPasteValues Case Is = 10 shtleads.Cells(lastrowleads + rCount, 4).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 14).PasteSpecial xlPasteValues Case Is = 11 shtleads.Cells(lastrowleads + rCount, 5).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 15).PasteSpecial xlPasteValues Case Is = 12 shtleads.Cells(lastrowleads + rCount, 7).PasteSpecial xlPasteValues Case Is = 13 shtleads.Cells(lastrowleads + rCount, 8).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 9).PasteSpecial xlPasteValues Case Is = 14 shtleads.Cells(lastrowleads + rCount, 9).PasteSpecial xlPasteValues Case Is = 15 shtleads.Cells(lastrowleads + rCount, 10).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 8).PasteSpecial xlPasteValues Case Is = 16 shtleads.Cells(lastrowleads + rCount, 11).PasteSpecial xlPasteValues Case Is = 17 shtemail.Cells(lastrowemail + rCounte, 10).PasteSpecial xlPasteValues Case Is = 18 shtleads.Cells(lastrowleads + rCount, 29).PasteSpecial xlPasteValues Case Is = 19 shtleads.Cells(lastrowleads + rCount, 30).PasteSpecial xlPasteValues Case Is = 22 shtleads.Cells(lastrowleads + rCount, 31).PasteSpecial xlPasteValues Case Is = 23 shtleads.Cells(lastrowleads + rCount, 32).PasteSpecial xlPasteValues Case Is = 24 Case Is = 25 shtleads.Cells(lastrowleads + rCount, 33).PasteSpecial xlPasteValues shtleads.Cells(lastrowleads + rCount, 3).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 7).PasteSpecial xlPasteValues Case Is = 29 shtleads.Cells(lastrowleads + rCount, 27).PasteSpecial xlPasteValues Case Is = 28 shtleads.Cells(lastrowleads + rCount, 26).PasteSpecial xlPasteValues Case Is = 30 shtleads.Cells(lastrowleads + rCount, 20).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 2).PasteSpecial xlPasteValues Case Is = 31 shtleads.Cells(lastrowleads + rCount, 28).PasteSpecial xlPasteValues Case Is = 32 If shtcoco.Cells(i, b).Value = "M" Then shtemail.Cells(lastrowemail + rCounte, 3).Value = "Mr." shtleads.Cells(lastrowleads + rCount, 21).Value = "Mr." ElseIf shtemail.Cells(i, b).Value = "F" Then shtemail.Cells(lastrowemail + rCounte, 3).Value = "Ms." shtleads.Cells(lastrowleads + rCount, 21).Value = "Ms." Else: shtleads.Cells(lastrowleads + rCount, 21).PasteSpecial xlPasteValues shtemail.Cells(lastrowemail + rCounte, 3).PasteSpecial xlPasteValues End If End Select Next b End Select If shtcoco.Cells(i, 1).Value = "Leads" Then rCount = rCount + 1 ElseIf shtcoco.Cells(i, 1).Value = "Email" Then rCounte = rCounte + 1 ElseIf shtcoco.Cells(i, 1).Value = "Both" Then rCount = rCount + 1 rCounte = rCounte + 1 End If Next i wkbemail.Close SaveChanges:=True wkbleads.Close SaveChanges:=True Application.ScreenUpdating = True MsgBox rCount & " rows(s) added to Leads and " & rCounte & " to Email list.", 0, "Transfer complete!" End Sub
Merci pour l'aide!