Thema Datum  Von Nutzer Rating
Antwort
19.09.2018 09:28:26 Thomas
NotSolved
19.09.2018 10:33:19 Thomas
NotSolved
19.09.2018 10:40:27 Flotter Feger
NotSolved
Blau Merkwürdige 400 Error-Message
19.09.2018 11:35:21 Thomas
NotSolved
19.09.2018 13:37:50 Flotter Feger
NotSolved
19.09.2018 13:46:17 Thomas
NotSolved
19.09.2018 14:08:22 Flotter Feger
NotSolved
19.09.2018 14:19:49 Thomas
NotSolved
19.09.2018 16:59:46 Thomas
NotSolved
19.09.2018 18:01:51 Mackie
NotSolved
19.09.2018 18:50:59 Gast42663
NotSolved
19.09.2018 18:54:42 Mackie
NotSolved
19.09.2018 19:00:33 Thomas
NotSolved
19.09.2018 18:59:59 Mackie
NotSolved
19.09.2018 19:01:42 Thomas
NotSolved
19.09.2018 19:03:10 Mackie
NotSolved
19.09.2018 19:13:09 Thomas
NotSolved
19.09.2018 19:30:48 Mackie
NotSolved
19.09.2018 19:39:44 Thomas
NotSolved
19.09.2018 19:40:22 Thomas
NotSolved
19.09.2018 19:54:48 Mackie
NotSolved
19.09.2018 20:09:15 Gast43707
NotSolved
19.09.2018 20:22:15 Thomas
NotSolved
19.09.2018 20:29:23 Thomas
NotSolved
19.09.2018 21:45:09 Mackie
NotSolved
19.09.2018 20:46:09 Mackie
NotSolved
19.09.2018 21:44:08 Mackie
NotSolved

Ansicht des Beitrags:
Von:
Thomas
Datum:
19.09.2018 11:35:21
Views:
728
Rating: Antwort:
  Ja
Thema:
Merkwürdige 400 Error-Message

Vielen Dank für die Antwort Flotter Feger.

Habe hier mal den Code reingepackt, wo denkst du könnte ich einen bereits vergebenen Namen zugeordnet haben? 

 

Vielen dank im Voraus und beste Grüße

 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
Sub loeschen()
 
 
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws As Worksheet
Set ws = Tabelle1
Dim ws2 As Worksheet
Set ws2 = Tabelle2
 
 
Dim wb2 As Workbook
 
Tabelle1.UsedRange.ClearContents
'On Error GoTo Errorhandler2
Tabelle1.UsedRange.ClearContents
Tabelle1.UsedRange.ClearFormats
Tabelle1.UsedRange.ClearFormats
 
'Errorhandler2:
 
On Error Resume Next
Tabelle2.ShowAllData
Tabelle2.UsedRange.Copy ws.Cells(1, 1)
 
Tabelle2.UsedRange.ClearContents
Tabelle2.UsedRange.ClearContents
Tabelle2.UsedRange.ClearFormats
Tabelle2.UsedRange.ClearFormats
 
'On Error GoTo Errorhandler
For i = 1 To 12
    If ws.Cells(2, i) = "Part#_new" Then
Tabelle1.Cells.Replace What:="Part#_new", Replacement:="Part#", SearchOrder:=xlByColumns, MatchCase:=True
Tabelle1.Cells.Replace What:="Description_new", Replacement:="Description", SearchOrder:=xlByColumns, MatchCase:=True
Tabelle1.Cells.Replace What:="Royalities_new", Replacement:="Royalities", SearchOrder:=xlByColumns, MatchCase:=True
    End If
Next
 
'Errorhandler:
Dim myfilenamepicker As FileDialog
Set myfilenamepicker = Application.FileDialog(msoFileDialogFilePicker) ' Filedialog ermöglicht dialog, msoFileDialogFolderPicker ermöglicht es einen Ordner auszuwählen
myfilenamepicker.InitialFileName = "G:\Departments\Reporting Analyzing\_Downloads"
myfilenamepicker.Show
If myfilenamepicker.SelectedItems.Count <> 0 Then
myfilename = myfilenamepicker.SelectedItems(1)
 
Set wb2 = ThisWorkbook.Application.Workbooks.Open(myfilename)
Debug.Print (myfilename)
Dim ws3 As Worksheet
Set ws3 = wb2.Worksheets(TabellenIndex(wb2, "Tabelle1")) 'Wieso kann ich hier nicht die Funktion nutzen?
On Error Resume Next
ws3.ShowAllData
ws3.UsedRange.Copy ws2.Cells(1, 1)
Debug.Print (ws3.Name)
 
End If
 
 
wb2.Close SaveChanges:=False
 
Call kopiereneinfügengundh
Call in_analysis_bom_pasten
 
 
End Sub
Function TabellenIndex(ByRef wkb As Workbook, ByVal strCodename As String) As Integer
'Set wkb = ThisWorkbook.Application.Workbooks.Open("G:\Departments\Procurement\T-BAR\.xls")
'
Dim wks As Worksheet
For Each wks In wkb.Worksheets
  If wks.CodeName = strCodename Then
    TabellenIndex = wks.Index
    Exit Function
  End If
Next wks
End Function
 
 
Sub kopiereneinfügengundh()
 
Dim ws As Worksheet
Set ws = Tabelle1
Dim wsnew As Worksheet
Set wsnew = Tabelle2
 
Dim lrow As Integer
Dim Oldcell As Range
Dim arrCriteria() As String
Dim lngCriteriaCount As Long
Dim element As Variant
 
Dim lrownew As Integer
Dim NewCell As Range
 
 
lngCriteriaCount = 2
 
ReDim arrCriteria(0 To lngCriteriaCount - 1)
arrCriteria(0) = "Description"
arrCriteria(1) = "Part#"
 
Tabelle4.UsedRange.ClearContents
Tabelle4.UsedRange.ClearFormats
 
lrow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrownew = wsnew.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrowpaste = Tabelle1.UsedRange.SpecialCells(xlCellTypeLastCell).Row
 
 
Debug.Print (lrowpaste)
 
If ws.AutoFilterMode = False Then
ws.Rows(2).AutoFilter
End If
 
If wsnew.AutoFilterMode = False Then
wsnew.Rows(2).AutoFilter
End If
 
 
For i = 1 To 30
    If ws.Cells(2, i).Value = "Typ" Then
    ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="KT"
    End If
Next
 
For i = 1 To 30
    If ws.Cells(2, i).Value = "Quantity" Then
    ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="<>0"
    End If
Next
 
For i = 1 To 30
    If wsnew.Cells(2, i).Value = "Typ" Then
    wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="KT"
    End If
Next
 
For i = 1 To 30
    If wsnew.Cells(2, i).Value = "Quantity" Then
    wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="<>0"
    End If
Next
 
 
 
For i = 1 To 10
Set Oldcell = ws.Cells(2, i)
    For Each element In arrCriteria()
        If element = ws.Cells(2, i).Value Then
        ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).SpecialCells(xlCellTypeVisible).Copy Tabelle4.Cells(1, i) 'Muss hier "Category" schreiben und geht nicht in Abhängigkeit eines Arrays, wieso?
        End If
    Next
Next
 
 
 
For i = 1 To 10
Set NewCell = wsnew.Cells(2, i)
    For Each element In arrCriteria()
        If element = wsnew.Cells(2, i).Value Then
            wsnew.Range(wsnew.Cells(3, i), wsnew.Cells(lrownew, i)).SpecialCells(xlCellTypeVisible).Copy Tabelle4.Cells(lrowpaste, i) 'Problem: Lrowpaste nimmt die lrow, bevor Daten aus Tabelle1 eingefügt werden
        End If
    Next
Next
 
 
 
' Aus dem range in anderen tabelle Fund G rausziehen als Variable
    lrow4 = Tabelle4.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    Tabelle4.Range(Tabelle4.Cells(1, 6), Tabelle4.Cells(lrow4, 7)).RemoveDuplicates Columns:=2, Header:=xlYes 'das sollte noch in Abhängigkeit von i gehen, irgendwie oben einbauen oder schauen ob es sowas wie first und last column gibt, dann vorher Blatt clearen
 
'Alternative statt mit dem For...each zu arbeiten
'Dim i As Long, ialngIndex As Long
''...
'For i = 1 To 10
'   '...
'    For ialngIndex = 0 To UBound(arrCriteria)
'        If ws.Cells(2, i).Value = arrCriteria(ialngIndex) Then
'            ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).Copy Tabelle4.Cells(10, 10) '10,10 zu was Sinnvollem anpassen
'        End If
'    Next
'Next
''...
 
End Sub
Sub in_analysis_bom_pasten()
 
Dim ws1 As Worksheet
Set ws1 = Tabelle4
Dim wsanalysis As Worksheet
Set wsanalysis = Tabelle3
 
Dim lrow As Integer
 
Dim arrCriteria() As String
Dim lngCriteriaCount As Long
 
lngCriteriaCount = 3
 
ReDim arrCriteria(0 To lngCriteriaCount - 1)
arrCriteria(0) = "Category"
arrCriteria(1) = "Part#"
arrCriteria(2) = "Description"
 
 
'!!!!! In Allen tabellen in Analysis BOM noch in Zeile 17 die Spaltenbeschriften (Spalte B + C) machen, damit For-Schleife zieht
 
 
If Tabelle3.AutoFilterMode = True Then
On Error GoTo Errorhandler:
    Tabelle3.ShowAllData
  End If
 
Errorhandler:
 
lrow1 = wsanalysis.UsedRange.SpecialCells(xlCellTypeLastCell).Row
 
For i = 1 To 30
    For Each element In arrCriteria()
        If wsanalysis.Cells(17, i) = element Then
            wsanalysis.Range(wsanalysis.Cells(18, i), wsanalysis.Cells(lrow1, i)).Clear
        End If
    Next
Next
 
For i = 1 To 30
    For j = 1 To 10
        If wsanalysis.Cells(17, j) = ws1.Cells(1, i).Value Then 'Royalties wurden falsch geschrieben
          ws1.Range(ws1.Cells(2, i), ws1.Cells(lrow1, i)).SpecialCells(xlCellTypeVisible).Copy wsanalysis.Cells(18, j) 'Pasten noch machen wsbol.einsunterroyalties (Range("G4") G = j 4 lastrow mit offset von j
 
        End If
    Next
Next
 
End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
19.09.2018 09:28:26 Thomas
NotSolved
19.09.2018 10:33:19 Thomas
NotSolved
19.09.2018 10:40:27 Flotter Feger
NotSolved
Blau Merkwürdige 400 Error-Message
19.09.2018 11:35:21 Thomas
NotSolved
19.09.2018 13:37:50 Flotter Feger
NotSolved
19.09.2018 13:46:17 Thomas
NotSolved
19.09.2018 14:08:22 Flotter Feger
NotSolved
19.09.2018 14:19:49 Thomas
NotSolved
19.09.2018 16:59:46 Thomas
NotSolved
19.09.2018 18:01:51 Mackie
NotSolved
19.09.2018 18:50:59 Gast42663
NotSolved
19.09.2018 18:54:42 Mackie
NotSolved
19.09.2018 19:00:33 Thomas
NotSolved
19.09.2018 18:59:59 Mackie
NotSolved
19.09.2018 19:01:42 Thomas
NotSolved
19.09.2018 19:03:10 Mackie
NotSolved
19.09.2018 19:13:09 Thomas
NotSolved
19.09.2018 19:30:48 Mackie
NotSolved
19.09.2018 19:39:44 Thomas
NotSolved
19.09.2018 19:40:22 Thomas
NotSolved
19.09.2018 19:54:48 Mackie
NotSolved
19.09.2018 20:09:15 Gast43707
NotSolved
19.09.2018 20:22:15 Thomas
NotSolved
19.09.2018 20:29:23 Thomas
NotSolved
19.09.2018 21:45:09 Mackie
NotSolved
19.09.2018 20:46:09 Mackie
NotSolved
19.09.2018 21:44:08 Mackie
NotSolved