Tomasz
Karowski
.NET contractor
providing
programming services
Tomasz
Gawęda
Kierownik Zakładu
Produkcyjnego
Tomasz
Karowski
.NET contractor
providing
programming services
Agata Grygoruk młodszy programista
Robert M. finanse i bankowosc
Bogdan
Gilarski
www.excelperfect.pl
Perfect And
Practical
пропозиції роботи
Arkusz1.Range("A10:D10").copy Arkusz2.Range("A"&wiersz)gdzie "wiersz" to zmienna określona przez "ostatni wiersz" +1, Arkusz1, Arkusz2 to nazwy kodowe arkuszy kopiowane z -> kopiowane do...
Łukasz
Kuchejda
Kontroler przepływu
materiałów
Option Explicit
Sub dzialaj()
Dim ark As Worksheet, temp As Worksheet
Dim i As Integer
Set ark = Sheets("Arkusz1")
For i = 1 To ark.Range("d65536").End(xlUp).Row
If Not czyistnieje(ark.Cells(i, 4)) Then
Sheets.Add
Set temp = ActiveSheet
temp.Name = ark.Cells(i, 4)
temp.Move After:=Sheets(Sheets.Count)
Call esql(ark.Cells(i, 4), temp.Name)
End If
Next i
End Sub
Function esql(argument As String, arkusz As String)
Dim cn As Object, rs As Object
Dim nazwa As String, sqlstr As String
Dim ark As Worksheet
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
nazwa = ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & nazwa & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"""
sqlstr = "SELECT * FROM [Arkusz1$] WHERE F4 = '" & argument & "'"
Set rs = cn.Execute(sqlstr)
Set ark = ActiveWorkbook.Sheets(arkusz)
ark.Cells.ClearContents
ark.Range("a1").CopyFromRecordset rs
rs.Close
cn.Close
End Function
Function czyistnieje(nazwa As String) As Boolean
Dim ark As Worksheet
czyistnieje = False
For Each ark In ThisWorkbook.Worksheets
If ark.Name = nazwa Then czyistnieje = True
Next ark
End Function
Sławek Kucharski Zarządzanie to pasja
Oskar
Shon
Dodatki do Office
www.VBATools.pl
kopiować dane z jednego do drugiego pod warunkiem że dane są przypisane w pliku źródłowym do tech samego pracownika a nie zawsze w tym samym wierszu
Sławomir
Broda
VBA, Excel, Access,
SAP i wszystko
związane z
automatyzac...
Łukasz K.:wstaw
Witam serdecznie Jestem nowy na tym forum przyciągnęło mnie tu makro napisane przez Pana Tomasza Gawęda, chciał bym zapytać autora bądź też innych forumowiczów jak zmodyfikować to podstawowe makro:
Option Explicit
Sub dzialaj()
Dim ark As Worksheet, temp As Worksheet
Dim i As Integer
Set ark = Sheets("Arkusz1")
For i = 1 To ark.Range("d65536").End(xlUp).Row
If Not czyistnieje(ark.Cells(i, 4)) Then
Sheets.Add
Set temp = ActiveSheet
temp.Name = ark.Cells(i, 4)
temp.Move After:=Sheets(Sheets.Count)
Call esql(ark.Cells(i, 4), temp.Name)
End If
Next i
End Sub
Function esql(argument As String, arkusz As String)
Dim cn As Object, rs As Object
Dim nazwa As String, sqlstr As String
Dim ark As Worksheet
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
nazwa = ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & nazwa & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"""
sqlstr = "SELECT * FROM [Arkusz1$] WHERE F4 = '" & argument & "'"
Set rs = cn.Execute(sqlstr)
Set ark = ActiveWorkbook.Sheets(arkusz)
ark.Cells.ClearContents
ark.Range("a1").CopyFromRecordset rs
rs.Close
cn.Close
End Function
Function czyistnieje(nazwa As String) As Boolean
Dim ark As Worksheet
czyistnieje = False
For Each ark In ThisWorkbook.Worksheets
If ark.Name = nazwa Then czyistnieje = True
Next ark
End Function
tak aby po utworzeniu arkuszy na podstawie kolumny D po ponownym uruchomieniu dopisywało do nich nowe rekordy, które pojawiły się w arkuszu1. Na chwile obecną za każdym razem muszę
rrr = ark.range(ark.rows.count,1).end(xlup).row +1
ark.Range("a"&rrr).CopyFromRecordset rs
ark.Cells.ClearContents
ark.Range("a1").CopyFromRecordset rs
usunąć powstałe arkusze i uruchomić makro ponownie. Drugie pytanie czy jest możliwość w jakiś sposób ograniczyć ilość kolumn kopiowanych, bądź wskazać które kolumny z danego wiersza mają być skopiowane ?? Jeśli ktoś był by w stanie mi pomóc będę bardzo wdzięczny. Dopiero zaczynam
sqlstr = "SELECT * FROM [Arkusz1$] WHERE F4 = '" & argument & "'"
zabawę z VBA, więc prosił bym o ewentualne tłumaczenie jak dla laikaTen post został edytowany przez Autora dnia 22.07.13 o godzinie 09:07
Wojciech Gardziński
Sławomir
Broda
VBA, Excel, Access,
SAP i wszystko
związane z
automatyzac...
Wojciech G.:Gdyby zadał Pan sobie trud przeczytania tematu, a nie jak małpka wklejał swoje linki, to pewnie mógłby Pan wnieść coś do dyskusji.
http://www.afin.net/samples/Cases/AFIN.NET.Information...
Wiersz 8. to "kopiowanie" z filtrem.
Wierszy takich może być ilość dowolna.
Oskar
Shon
Dodatki do Office
www.VBATools.pl
konto usunięte
Oskar
Shon
Dodatki do Office
www.VBATools.pl
Oskar
Shon
Dodatki do Office
www.VBATools.pl
1
2
4
5
6
1
2
4
5
6
1
2
4
5
6
Sub KopiujDoArkusza2()Ten post został edytowany przez Autora dnia 11.03.14 o godzinie 20:13
Dim wksDane1 As Worksheet
Dim wksDane2 As Worksheet
Set wksDane1 = Worksheets("Arkusz1")
Set wksDane2 = Worksheets("Arkusz2")
For i = 1 To 10
If wksDane1.Range("A" & i).Value > "" Then
wksDane2.Range("A" & i).Value = wksDane1.Range("A" & i).Value
End If
Next i
End Sub
Oskar
Shon
Dodatki do Office
www.VBATools.pl
Sub KopiujDoArkusza2()
Dim i as long, x as long
Dim wksDane1 As Worksheet
Dim wksDane2 As Worksheet
Set wksDane1 = Worksheets("Arkusz1")
Set wksDane2 = Worksheets("Arkusz2")
For i = 1 To 10
If wksDane1.Range("A" & i).Value > "" Then
x = x +1
wksDane2.Range("A" & x).Value = wksDane1.Range("A" & i).Value
End If
Next i
End Sub
Piotr
Z.
Technische
Dokumentation,
CE-Beaftragte,Glaub
Automation ...
Sub open_copy_paste_n_close()
Dim thiswkb As Workbook, wkb As Workbook, min_row&
Set thiswkb = ActiveWorkbook
Workbooks.Open Filename:= "O:\pliki\oferty_eksport.xlsx" 'arkusz źródłowy
Set wkb = ActiveWorkbook
Dim rng1 As Range, rng2 As Range
With wkb.Sheets(1)
Set rng1 = .Range("a3:m" & .Cells(Rows.Count, "a").End(xlUp).Row)
End With
With thiswkb.Sheets("Oferty") 'arkusz docelowy w pliku Zestawienie_ofert.xslx
min_row = .Cells(Rows.Count, "a").End(xlUp).Row
If Len(.Range("a1")) > 0 Then min_row = min_row + 1 'nagłówek
Set rng2 = .Range("a" & min_row)
End With
rng1.Copy rng2
Windows("Zestawienie_ofert.xlsx").Activate
Workbooks("oferty_eksport.xlsx").Close SaveChanges:=False
End Sub
Następna dyskusja:
