Excel mit Dialog ins Access importieren?

Hallo zusammen,

für den Import einer CSV mit Dialog(um beliebige Datei zu wählen) benutze ich folgender Code:

---------

Private Sub Befehl14_Click()

Dim fd As Object

Dim dateiname As String

Set fd = Application.FileDialog(1)

fd.AllowMultiSelect = False

fd.ButtonName = "Importieren"

With fd

If .Show = True Then

dateiname = fd.SelectedItems(1)

'DoCmd.TransferText acImportDelim, "txtImportSpezifikation", "Sales", dateiname

DoCmd.TransferText acImportDelim, "LEER1", "Sales", dateiname

Else

Set fd = Nothing

End If

End With

End Sub

--------

will gerne aber für Excel- Was muss ich am besten anpassen an den Code?

Vielen Dank im voraus

Gruß

Sahaj

20.04.2022, 15:19

keine Idee?

1 Antwort

Weasel6666

Nutzer, der sehr aktiv auf gutefrage ist

im Thema Microsoft Excel

03.05.2022, 14:07

Hallo Safah,

am besten machst du einen manuellen Excel-Import, speichert die Spezifikationen mit dem Namen 'ExcelImportSpezifikation' ab und ersetzt anschließend in deinem Code 'LEER1' mit 'ExcelImportSpezifikation'. Hier ein link zu einer englischsprachigen Erklärung: https://stackoverflow.com/questions/35341865/how-to-import-csv-file-to-access-with-vba-code

Grüße

Weasel

Hallo, ich würde gerne eine Rechnung mit einem Makro erstellen. Soweit klappt das auch und die Mail öffnet sich auch, aber diese wird nicht als Anhang hinzugefügt. Ich komme leider nicht drauf. Ich denke, es liegt daran, dass er die Datei nicht findet, aber ich wüsste keinen Lösungsansatz. Hier der Code:

Dim Result As VbMsgBoxResult

Sub RechnungsnrUndDrucken()

Sheets("Rechnung_Video").Select

[D15] = [D15] + 1 'Rechnungsnummer 1 hochzählen

Dim sCC As String

Dim sName As String

Dim sText As String

Dim sObject As String

Dim sCompany As String

Dim sRefNr As String

Dim sTempFileName As String

If (CStr(ThisWorkbook.ActiveSheet.Name) = "Rechnung") Then

Result = MsgBox("Rechnung fertig?", vbApplicationModal Or vbQuestion Or vbYesNo)

If Result = vbNo Then Exit Sub

End If

Const DateiPfad = "C:\Temp\"

Dim DateiName As String

DateiName = DateiPfad & Range("C15") & Range("D15") & ".pdf"

Range("A1:F54").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

DateiName, Quality:=xlQualityStandard, _

IncludeDocProperties:=True, _

IgnorePrintAreas:=False, _

OpenAfterPublish:=False

Dim Nachricht As Object, OutApp As Object

Dim AWS As String

Set OutApp = CreateObject("Outlook.Application")

AWS = strFileName

'InitializeOutlook = True

Set Nachricht = OutApp.CreateItem(0)

With Nachricht

.Subject = "" & Range("A1") & "_" & Range("C15") & Range("D15")

.GetInspector.display

'.Attachments.Add ("C:\Temp\" & Range("C15") & Range("D15") & ".pdf")

End With

Set OutApp = Nothing

Set Nachricht = Nothing

End Sub

...zur Frage

Excel - Speicher-datum in Kopfzeile?

möchte immer das letzte Speicherdatum in der Kopfzeile. Habe bereits mehrere Lösungen gegoogelt, aber funktionieren tun sie nicht. Wo mache ich den Fehler?

Habe folgenden Befehl eingegeben

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim booIsSaved As Boolean
Dim strDatInfo As String
With ThisWorkbook
booIsSaved = .Saved
If .Path <> "" Then
strDatInfo = .BuiltinDocumentProperties("Last save time")
Else
strDatInfo = "noch nicht gespeichert"
End If
ActiveSheet.PageSetup.LeftHeader = "Zuletzt gespeichert: " & strDatInfo
.Saved = booIsSaved
End With
End Sub

Und hier noch einen printscreen. Besten Dank

...zur Frage

Excel VBA Zellen in ein anderes Tabellenblatt Kopieren wenn Bedingung erfüllt?

Hallo,

ich habe ein problem und habe keine Ahnung von VBA.

Ich habe eine Tabelle in "A" steht der Name in "P" der Kurs und in "Y" ist die Bedingung "ja" oder "nein".

Das war das einzige das ich gefunden habe was auch funktionierte. Allerdings Kopiert es die komplette Zeile.

Sub BedingteKopieZeilen()

Dim Zeile As Long

Dim ZeileMax As Long

Dim n As Long

With Tabelle2

ZeileMax = .UsedRange.Rows.Count

n = 7

For Zeile = 3 To ZeileMax

If .Cells(Zeile, 25).Value = "Kurtaxe" Then

.Rows(Zeile).Copy Destination:=Tabelle10.Rows(n)

n = n + 1

End If

Next Zeile

End With

End Sub

Ich bedanke mich für eure Hilfe

Bernd

...zur Frage

Ich benötige einen Makro, um ausgewählte Filter beim Schliessen zurück zu setzen. Aber mit dem Blattschutz funktioniert das nicht mehr. Kann mir jemand helfen?

Ich habe bisher diesen Makro benutzt:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        With wksSheet
            If .AutoFilterMode Then
                If .FilterMode Then
                    .ShowAllData
                End If
            End If
        End With
    Next wksSheet
    ThisWorkbook.Save
End Sub

...zur Frage

Excel VBA: Text aus Inputbox in Zelle ergänzen (nicht überschreiben)

Hallo ihr Lieben Excel-Profis,

ich hab ein kleines Excel-File, welches ich täglich öffne und wo ich zum aktuellen Datum einen Eintrag mache). Das passiert über eine Inputbox. Wenn ich aber das Excel ein zweites Mal öffne und einen neuen Text eingeben, dann überschreibt es mir den alten Text. Ich würde jetzt gerne mein Makro so umbauen, dass ich den Text in die Zelle dazuschreibe. Sub eintragen()

Dim x As Range Dim symptom As String

symptom = InputBox("heutige Symptome:", "In Spalte D", "") If symptom = "" Then Exit Sub With Sheets("Kalender") Set x = .Range("D:D").Find(Date) If x Is Nothing Then MsgBox "Der " & Date & " wurde nicht gefunden!" Else .Cells(x.Row, 6) = symptom End If End With End Sub

Bitte um Unterstützung!

Danke! :-)

...zur Frage

Maximale Pfadlänge in Windows und VBA umgehen?

Hallo,

ich benutze folgenden Code in Excel VBA um mir Dateipfad und Dateiname eines Ordners und allen darin enthaltenen Unterordnern aufzulisten.
(Ihr könnt es testen, den Code einfach in ein Modul kopieren, "MainList" ausführen und einen Ordner eurer Wahl auswählen)

Ich habe jetzt das Problem, dass dieser Code alle Dateien überspringt, deren Pfadlänge über 255 Zeichen lang ist. Einige Dateien überschreiten nämlich die 255 Zeichen mit dem angehängten Dateinamen.
Sie liegen aber dennoch ab. Nur liest VBA diese nicht aus. Kann man da was dran machen?

Sub MainList()
'Updateby Extendoffice
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
End Sub

Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
  Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Path
  Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Name
  rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
  For Each xSubFolder In xFolder.SubFolders
    ListFilesInFolder xSubFolder.Path, True
  Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
End Sub

Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
  Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
  GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function

...zur Frage

Bei Serienbrief Dokumente einzeln Speichern mit Makro funktioniert nicht?

Ich möchte die Dokumente im Serienbrief einzeln automatisch speichern mittels Makro und habe das unten angefügte Makro dafür auch gefunden aber es funktioniert bei mir noch nicht sondern debugt immer und zeigt Fehler in der Variable an. Ich hab auch den Pfad schon auf mein Dokument angepasst. Muss ich evtl noch den Dateinamen ändern?

Sub Test()
 '
 ' Serienbrief in einzelnen Word Dokumenten speichern
 '
 Dim Dateiname As String
 Dim LetzterRec As Long
     
 Application.ScreenUpdating = False
 Application.Visible = False

 Const path As String = "C:\Test\"          'Pfad anpassen
 ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord
 LetzterRec = Word.ActiveDocument.MailMerge.DataSource.ActiveRecord
 ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord


     With ActiveDocument.MailMerge
         .DataSource.ActiveRecord = wdFirstRecord
         Do
             If .DataSource.ActiveRecord > 0 Then
                If .DataSource.DataFields("VorNachname").Value <> "0" Then
                     .Destination = wdSendToNewDocument
                    .SuppressBlankLines = True

                     With .DataSource
                         .FirstRecord = .ActiveRecord
                         .LastRecord = .ActiveRecord
                
                         Dateiname = path & .DataFields("VorNachname").Value & ".docx"
                
                     End With
                        .Execute Pause:=False
                 
                         ActiveDocument.SaveAs FileName:=Dateiname           'Speichern unter Dateiname
                        ActiveDocument.Close False
                 End If

               End If
               
             If .DataSource.ActiveRecord < LetzterRec Then
                 .DataSource.ActiveRecord = wdNextRecord
             Else
                 Exit Do
             End If
         Loop
     End With
     
     Application.Visible = True
     Application.ScreenUpdating = True
 End Sub

...zur Frage

Excel Macro: Formel dynamisch machen, um Zellenbereich auszuwählen?

Liebe Community,

ich habe folgendes Macro in meiner Excel Tabelle. Es funktioniert auch wunderbar, bis auf die Tatsache, dass dort der Tabellenbereich aus der fremden Excel-Datei definiert ist.

Leider sind es nicht immer 239 Zeilen. Mal mehr und mal weniger. Dass es bei A7 anfängt, das stimmt schon. Wie müsste ich die Formel ändern, damit Excel sich automatisch anpasst?

Vielen lieben Dank im Voraus!

Es handelt sich um diese Zeile wbQuelle.Worksheets(1).Range("A7:I239").Copy

Sub Quelle()

Dim sPfad As String
Dim wbQuelle As Workbook
Dim zelle As Range

sPfad = "C:\Users\Beispiel\Desktop\Irgendeine Datei\Daten\Daten.xlsx"

If Dir(sPfad) <> "" Then

Set wbQuelle = Workbooks.Open(sPfad)

wbQuelle.Worksheets(1).Range("A7:I239").Copy ThisWorkbook.Worksheets(3).Range("B2")

wbQuelle.Close savechanges:=False

End If

End Sub

...zur Frage

Excel: Verbessertes Logging mit VBA Makro?

Hallo Zusammen

ich verwende im Moment ein kurzes Makro, um Änderungen in einem Tabellenblatt zu loggen.

Es registriert aber nur einzelne Änderungen, nicht multi-selektion oder Löschen von Spalten. Kann ich das mit separaten Privaten Subs übernehmen?

Und kann ich aufnehmen, was die Target- und "PreVal"-Adresse war (Offset 4+5)

Code:

Dim PreVal
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
PreVal = Target.Value
 
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  
    On Error GoTo 0
    
    If Target.Value <> PreVal Then
        With Sheets(2).Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = Now
            .Offset(1, 1) = PreVal
            .Offset(1, 2) = Target.Value
            .Offset(1, 3) = Environ("Username")
        End With
    End If
 
End Sub

...zur Frage

Excel Arbeitsmappe separat speichern mit VBA?

Hallo,

habe bei meiner Exceldatei 10 Arbeitsmappen und ich möchte eine Arbeitsmappe davon separat als Datei abspeichern sodass ich unten nur mehr eine Arbeitsmappe stehen habe.

Habe mir hierfür einen einen Knopf erstellt und mit VBA den Knopf programmiert. Wenn ich ihn drücke, dann habe ich es bereits geschafft, dass die Mappe sich als PDF exportiert aber als Excel ist nicht möglich. Hier ist mein Code:

Sub EXCEL_erstellen()

Dim DateiName As String

DateiName = Range("AB3") & Range("AB2")

Range("A1:T61").ExportAsFixedFormat Type:=xlTypeXPS, Filename:=DateiName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

End Sub

...zur Frage

Name + User?

Hallo,

was müsste ich hier anpassen? Ich komme mit der Fehler Meldung nicht zurecht.

Private Declare 36 GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Function GetNTUserA() As String
  
 Dim sBuffer As String
 Dim LSize As Long
 Dim user As String
  
 sBuffer = Space$(255)
 LSize = Len(sBuffer)
  
 Call GetUserName(sBuffer, LSize)
  
 If LSize > 0 Then
  user = Left$(sBuffer, LSize - 1)
 Else
  user = vbNullString
 End If
  
 GetNTUserA = user
  
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
   
    If Target.Column = 6 Then
    Target.Offset(0, 11).Value = Date
  End If
      
    If Target.Column = 6 Then
    Target.Offset(0, 10).Value = GetNTUserA
  End If

End Sub

...zur Frage

VBA CODE Zellen nach bestimmten Textinhalt suchen und Zeile Färben?

Hallo, kann mir bitte jemanden mit dem Code behilflich sein?

Dieser Code sucht die Zellen in Spalte"A" nach bestimmten Textinhalt ab und bei Treffer löscht er die zughörige gesamte Zeile. Meine Frage: kann man diesen Code so ändern, dass anstatt die gefundene Zeile zu löschen nur mit einer Farbe z.B. Orange (44) färbt? Vielen Dank im Voraus.

Sub zeilenloeschen()
  Dim i As Long
  Dim letzteZeile As Long
  Dim suchBereich As Range
  Dim gefunden As Range
  Dim ersterTreffer As String
  Dim suchWert As String
  suchWert = "1" 'hier kommt dein Suchwert rein
  
  With ThisWorkbook.Sheets("Sheet4")
    letzteZeile = .Range("A" & Rows.Count).End(xlUp).Row
    Set suchBereich = .Range("A1:A" & letzteZeile)
    Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
    If Not gefunden Is Nothing Then
      ersterTreffer = gefunden.Address
      Do
        gefunden.Activate
        ActiveCell.EntireRow.Delete shift:=xlUp
        Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
      Loop While Not gefunden Is Nothing
    End If
  End With
End Sub

...zur Frage

Excel: Schiebepuzzle programmieren - Laufzeitfehler 424?

Liebe Community, ich habe versucht eine Schiebepuzzle aus Zahlen in Excel zu programmieren. Den Text seht ihr unten. Jedoch sobald ich auf Ausführen (Wiedergabe-Button) drücke, kommt folgender Fehler:

Laufzeitfehler '424':
Objekt erforderlich

Könnt ihr mir bitte helfen den Fehler zu finden?

Vielen Dank im Vorraus
Lamio13

Dim xpos As Integer   
Dim ypos As Integer  
Dim AlleKnoepfe(1 To 15) As CommandButton

Private Sub UserForm_Initialize()
Set AlleKnoepfe(1) = CommandButton1
Set AlleKnoepfe(2) = CommandButton2
...  
Set AlleKnoepfe(14) = CommandButton14
Set AlleKnoepfe(15) = CommandButton15
End Sub

Sub FindMich(ich As String)
    Dim ii As Integer
    Dim jj As Integer

    For jj = 1 To 4
                 For ii = 1 To 4
                      If (Cells(jj, ii) = ich) Then
                         xpos = ii
                          ypos = jj
                          ii = 5
                          jj = 5
                      End If
                 Next ii
    Next jj
End Sub
Private Sub KannMichBewegen()

    'untersuche, ob rechts frei ist
    If (Cells(ypos, xpos + 1) = "") Then
        Cells(ypos, xpos + 1) = Cells(ypos, xpos)
        Cells(ypos, xpos + 1) = ""
    End If

End Sub

Sub VerschiebMich(SchubladenNummer As Integer)
    'untersuche, ob rechts frei ist
    If (xpos < 4) Then
            If (Cells(ypos, xpos + 1) = "") Then
                Cells(ypos, xpos + 1) = Cells(ypos, xpos)
                Cells(ypos, xpos) = ""
                AlleKnoepfe(SchubladenNummer).Left = AlleKnoepfe(SchubladenNummer).Left + AlleKnoepfe(SchubladenNummer).Width
            End If
    End If

    'untersuche, ob unten frei ist
    If (ypos < 4) Then
            If (Cells(ypos + 1, xpos) = "") Then
                Cells(ypos + 1, xpos) = Cells(ypos, xpos)
                Cells(ypos, xpos) = ""
                AlleKnoepfe(SchubladenNummer).Top = AlleKnoepfe(SchubladenNumemr).Top + AlleKnoepfe(SchubladenNummer).Height
            End If
    End If

    'untersuche, ob links frei ist
    If (xpos > 1) Then
            If (Cells(ypos, xpos - 1) = "") Then
                Cells(ypos, xpos - 1) = Cells(ypos, xpos)
                Cells(ypos, xpos) = ""
                AlleKnoepfe(SchubladenNummer).Left = AlleKnoepfe(SchubladenNummer).Left + AlleKnoepfe(SchubladenNummer).Width
            End If
    End If

    'untersuche, ob oben frei ist
    If (ypos > 1) Then
            If (Cells(ypos - 1, xpos) = "") Then
                Cells(ypos - 1, xpos) = Cells(ypos, xpos)
                Cells(ypos, xpos) = ""
                AlleKnoepfe(SchubladenNummer).Top = AlleKnoepfe(SchubladenNumemr).Top + AlleKnoepfe(SchubladenNummer).Height
            End If
    End If

End Sub

Private Sub CommandButton1_Click()
    FindMich (CommandButton1.Caption)
    VerschiebMich (1)
    End Sub
...

...zur Frage

VBA Code Erklärung

Guten Abend zusammen. Könnte mir jemand weiterhelfen bei diesem Code. Was macht er genau in Excel? Also Die einzelnen Schritte die er durchläuft,.

Option Explicit

Public Sub Double_Red()
Dim lngZeile As Long
Dim lngZeilenSprung As Long
Dim strSuchwert As String

lngZeile = Cells(Rows.Count, 4).End(xlUp).Row

  For lngZeilenSprung = lngZeile To 1 Step -1
    strSuchwert = Cells(lngZeilenSprung, 4).Value
      If Application.WorksheetFunction.CountIf(Range(Cells(1, 4), Cells(lngZeile, 4)), strSuchwert) <> 1 Then
        Cells(lngZeilenSprung, 4).Interior.ColorIndex = 3
      End If
  Next lngZeilenSprung

End Sub

...zur Frage

Was möchtest Du wissen?

Deine Frage stellen