PDA

View Full Version : VBA Excel help



nihonjin2000
09-20-2015, 11:47 AM
hi I have a problem with vba code and I need help.
I woudl like to make a macro:

1) open files from folder
2) find text : for example : ;;dt;ct;;;;;
3) delete that text and everything below text.
4) save file and close documents


I can not create number 3 ( delete that text and everything below text.)

Please Help! I will be grateful

This is my vba code.


Sub Usuwanie_Pierwszego_wiersza()

' 4 zmienne

Dim Nazwa_pliku As String
Dim Kontynuacja As Variant
Dim WS As Worksheet
Dim komorka1 As Range

' path
Nazwa_pliku = Dir("*.csv*")

' msgbox window
Kontynuacja = MsgBox("To makro usunie 3 wiersze z katalogu roboczego." & vbLf & _
"in " & Application.DefaultFilePath & ", zaczynając od pliku : " & vbLf & _
Nazwa_pliku & " czy kontynuować?", vbYesNo, "UWAGA!")

' msgbox-choose
If Kontynuacja - vbNo Then Exit Sub

Application.DisplayAlerts = False

'open file
Workbooks.Open Nazwa_pliku
Application.StatusBar = Nazwa_pliku & "opened."

'find text
ActiveSheet.Cells.Find(What:=";;dt;ct", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
Set komorka1 = ActiveCell

'ActiveSheet.ActiveCell.Delete--??????
???

'Close file
ActiveWorkbook.Close True
Application.StatusBar = Nazwa_pliku & "closed."

Nazwa_pliku = Dir()

Application.DisplayAlerts = False
Application.StatusBar = False

End Sub

p45cal
09-20-2015, 01:02 PM
'ActiveSheet.ActiveCell.Delete--??????
???

becomes:


Range(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell), ActiveCell).EntireRow.Delete

SamT
09-20-2015, 01:03 PM
With ActiveSheet.Cells
Set komorka1 = .Find(What:=";;dt;ct", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not komorka1 Is Nothing Then
LastRow = Cells(Rows.Count, komorka1.Column).End(xlUp).Row
Rw = komorka1.Row
Rows(Rw & ":" & LastRow).Delete
End If
End With

nihonjin2000
09-21-2015, 12:52 AM
Thank you for your quick reply but the code is not working. code looking for the selected cell but does not delete text below.

I have created code below but I can not attach the code to a previous code.

can anyone help me to join 2 codes ?.
Please for help again.




Sub Usuwanie_koncowych_wierszy()

' Deklaracja 4 zmiennych:
Dim Ostatnia_Komorka As Long
Dim komorka1 As Range
Dim Zakres As Range
Dim komorka2 As Range

'Aktywacja pierwszej pustej komórki w kolumnie "A"
Range("A1").End(xlDown).Offset(1).Activate

'Aktywacja funkcji FIND wraz z parametrami
Ostatnia_Komorka = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
Set komorka2 = Range("b" & Ostatnia_Komorka)
Cells.Find(What:="*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
Set komorka1 = ActiveCell
Set Zakres = Range(komorka1, komorka2)

'Usunięcie danych z zakresu
Zakres.EntireRow.Select

End Sub




Code above join to Code below:


Sub Usuwanie_Pierwszego_wiersza()

' 4 zmienne

Dim Nazwa_pliku As String
Dim Kontynuacja As Variant
Dim WS As Worksheet
Dim komorka1 As Range

' path
Nazwa_pliku = Dir("*.csv*")

' msgbox window
Kontynuacja = MsgBox("To makro usunie 3 wiersze z katalogu roboczego." & vbLf & _
"in " & Application.DefaultFilePath & ", zaczynając od pliku : " & vbLf & _
Nazwa_pliku & " czy kontynuować?", vbYesNo, "UWAGA!")

' msgbox-choose
If Kontynuacja - vbNo Then Exit Sub

Application.DisplayAlerts = False

'open file
Workbooks.Open Nazwa_pliku
Application.StatusBar = Nazwa_pliku & "opened."

'find text
ActiveSheet.Cells.Find(What:=";;dt;ct", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
Set komorka1 = ActiveCell

'ActiveSheet.ActiveCell.Delete--??????
???

'Close file
ActiveWorkbook.Close True
Application.StatusBar = Nazwa_pliku & "closed."

Nazwa_pliku = Dir()

Application.DisplayAlerts = False
Application.StatusBar = False

End Sub

p45cal
09-21-2015, 05:05 AM
'ActiveSheet.ActiveCell.Delete--??????
???

becomes:


Range(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell), ActiveCell).EntireRow.Delete

The result is:

Sub Usuwanie_Pierwszego_wiersza()

' 4 zmienne

Dim Nazwa_pliku As String
Dim Kontynuacja As Variant
Dim WS As Worksheet
Dim komorka1 As Range

' path
Nazwa_pliku = Dir("*.csv*")

' msgbox window
Kontynuacja = MsgBox("To makro usunie 3 wiersze z katalogu roboczego." & vbLf & _
"in " & Application.DefaultFilePath & ", zaczynając od pliku : " & vbLf & _
Nazwa_pliku & " czy kontynuować?", vbYesNo, "UWAGA!")

' msgbox-choose
If Kontynuacja - vbNo Then Exit Sub

Application.DisplayAlerts = False

'open file
Workbooks.Open Nazwa_pliku
Application.StatusBar = Nazwa_pliku & "opened."

'find text
ActiveSheet.Cells.Find(What:=";;dt;ct", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
Set komorka1 = ActiveCell

Range(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell), ActiveCell).EntireRow.Delete

'Close file
ActiveWorkbook.Close True
Application.StatusBar = Nazwa_pliku & "closed."

Nazwa_pliku = Dir()

Application.DisplayAlerts = False
Application.StatusBar = False

End Sub