K
Karol_tom
Hi,
I want to ask user for value and then sum all values > 0
My code doesn't work properly
Sub Makro1()
'
' Makro1 Makro
'
''find columns odpowiednie kolumny
Dim kolumna(1 To 4) As Integer
Dim n(1 To 4) As String
n(1) = "Open Amount"
n(2) = "Foreign Amt Open"
n(3) = "Curr Code"
n(4) = "Address Number"
'''last column and last row
ostatniakolumna = Range("A1").End(xlToRight).Column
ostatniWIERSZ = Range("A1").End(xlDown).Row
For j = 1 To 4
For i = 1 To ostatniakolumna
If Trim(Cells(1, i).Value) = n(j) Then
kolumna(j) = i
Exit For
End If
Next i
If kolumna(j) = 0 Then
MsgBox "Nie znaleziono kolumny z naglowkiem: " & n(j) & vbNewLine
& "Prosze popraw to (byc moze po prostu nie jestes w odpowiednim arkuszu),
bo makro nie bedzie dzialac poprawnie", vbCritical, "problem"
Exit Sub
End If
Next j
MsgBox kolumna(1) & vbNewLine & kolumna(2) & vbNewLine & kolumna(3) &
vbNewLine & kolumna(4)
''''kropki na przecinki
Columns(kolumna(1)).Select
Cells.Replace What:=",", Replacement:="", LookAt:=xlPart, SearchOrder:=
_
xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
Columns(kolumna(2)).Select
Cells.Replace What:=",", Replacement:="", LookAt:=xlPart,
SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
waluta = InputBox("Proaze podac trzyliterowy kod waluty", "Waluta")
waluta = UCase(waluta)
If Len(Trim(waluta)) <> 3 Then
MsgBox "DLUGOSC ROZNA OD 3 !!!!", vbCritical, "Nieprawdlowy kod waluty"
Exit Sub
End If
'''skopiujemy sobie waluty i numery (tylko unikalne)
Range(Cells(1, kolumna(3)), Cells(ostatniWIERSZ, kolumna(3))).AdvancedFilter
Action:=xlFilterCopy, copytorange:=(Cells(1, ostatniakolumna + 2)),
Unique:=True
Range(Cells(1, kolumna(4)), Cells(ostatniWIERSZ,
kolumna(4))).AdvancedFilter Action:=xlFilterCopy, copytorange:=(Cells(1,
ostatniakolumna + 3)), Unique:=True
'''no to zobaczmy ile tych rekordow wypisal (tak naprawde jest ich mniej o
jeden
ilewalut = Cells(1, ostatniakolumna + 2).End(xlDown).Row
iledostawcow = Cells(1, ostatniakolumna + 3).End(xlDown).Row
Range(Cells(2, ostatniakolumna + 2), Cells(ilewalut, ostatniakolumna +
2)).Select
Selection.Copy
Cells(1, ostatniakolumna + 4).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
''''to teraz zaczynamy jazde
'''po wszystkich dostawcach
g = 1
For x = ostatniakolumna + 4 To ostatniakolumna + 3 + ilewalut
For y = 2 To ostatniWIERSZ
g = g + 1
If g = iledostawcow + 1 Then
Exit For
End If
If ((Cells(g, ostatniakolumna + 3).Value = Cells(y,
kolumna(4)).Value) And (Cells(1, x).Value = Cells(y, kolumna(3)).Value))
Then
''''''''''''''''''''''
If Cells(y, kolumna(3)).Value = waluta Then
sumujpo = kolumna(1)
Else
sumujpo = kolumna(2)
End If
'''''''''''''''''''''''''
If Cells(y, sumujpo).Value > 0 Then
Cells(g, x) = Cells(g, x) + Cells(y, sumujpo)
End If
End If
Next y
Next x
End Sub
I want to ask user for value and then sum all values > 0
My code doesn't work properly
Sub Makro1()
'
' Makro1 Makro
'
''find columns odpowiednie kolumny
Dim kolumna(1 To 4) As Integer
Dim n(1 To 4) As String
n(1) = "Open Amount"
n(2) = "Foreign Amt Open"
n(3) = "Curr Code"
n(4) = "Address Number"
'''last column and last row
ostatniakolumna = Range("A1").End(xlToRight).Column
ostatniWIERSZ = Range("A1").End(xlDown).Row
For j = 1 To 4
For i = 1 To ostatniakolumna
If Trim(Cells(1, i).Value) = n(j) Then
kolumna(j) = i
Exit For
End If
Next i
If kolumna(j) = 0 Then
MsgBox "Nie znaleziono kolumny z naglowkiem: " & n(j) & vbNewLine
& "Prosze popraw to (byc moze po prostu nie jestes w odpowiednim arkuszu),
bo makro nie bedzie dzialac poprawnie", vbCritical, "problem"
Exit Sub
End If
Next j
MsgBox kolumna(1) & vbNewLine & kolumna(2) & vbNewLine & kolumna(3) &
vbNewLine & kolumna(4)
''''kropki na przecinki
Columns(kolumna(1)).Select
Cells.Replace What:=",", Replacement:="", LookAt:=xlPart, SearchOrder:=
_
xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
Columns(kolumna(2)).Select
Cells.Replace What:=",", Replacement:="", LookAt:=xlPart,
SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False
waluta = InputBox("Proaze podac trzyliterowy kod waluty", "Waluta")
waluta = UCase(waluta)
If Len(Trim(waluta)) <> 3 Then
MsgBox "DLUGOSC ROZNA OD 3 !!!!", vbCritical, "Nieprawdlowy kod waluty"
Exit Sub
End If
'''skopiujemy sobie waluty i numery (tylko unikalne)
Range(Cells(1, kolumna(3)), Cells(ostatniWIERSZ, kolumna(3))).AdvancedFilter
Action:=xlFilterCopy, copytorange:=(Cells(1, ostatniakolumna + 2)),
Unique:=True
Range(Cells(1, kolumna(4)), Cells(ostatniWIERSZ,
kolumna(4))).AdvancedFilter Action:=xlFilterCopy, copytorange:=(Cells(1,
ostatniakolumna + 3)), Unique:=True
'''no to zobaczmy ile tych rekordow wypisal (tak naprawde jest ich mniej o
jeden
ilewalut = Cells(1, ostatniakolumna + 2).End(xlDown).Row
iledostawcow = Cells(1, ostatniakolumna + 3).End(xlDown).Row
Range(Cells(2, ostatniakolumna + 2), Cells(ilewalut, ostatniakolumna +
2)).Select
Selection.Copy
Cells(1, ostatniakolumna + 4).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
''''to teraz zaczynamy jazde
'''po wszystkich dostawcach
g = 1
For x = ostatniakolumna + 4 To ostatniakolumna + 3 + ilewalut
For y = 2 To ostatniWIERSZ
g = g + 1
If g = iledostawcow + 1 Then
Exit For
End If
If ((Cells(g, ostatniakolumna + 3).Value = Cells(y,
kolumna(4)).Value) And (Cells(1, x).Value = Cells(y, kolumna(3)).Value))
Then
''''''''''''''''''''''
If Cells(y, kolumna(3)).Value = waluta Then
sumujpo = kolumna(1)
Else
sumujpo = kolumna(2)
End If
'''''''''''''''''''''''''
If Cells(y, sumujpo).Value > 0 Then
Cells(g, x) = Cells(g, x) + Cells(y, sumujpo)
End If
End If
Next y
Next x
End Sub