Private Sub CommandButton1_Click() '++++++++++++++++++++++++++++++++++++++++ import csv.souboru-odkud kam
Application.ScreenUpdating = False
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;\\Freenas\Hdd1\Excell\dataexport.csv", Destination:=Range("Import!$A$1") _
)
.Name = "dataexport"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1250
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
Range("C:C,D:D,P:P,Q:Q,R:R").Select '+++++++++++++++++++++++++++++++Vybere sloupce C:D,smaže obsah bunek a odstraní sloupce
Selection.ClearContents
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select '+++++++++++++++++++++++++++++++Vybere B sloupec a nastaví formát datumu
Selection.NumberFormat = "m/d/yyyy"
Columns("R:R").Select '++++++++++++++++++++++++++++++++přehození prvního a posledního sloupce
Range("R1").Activate
Selection.Copy
Columns("S:S").Select
Range("S1").Activate
ActiveSheet.Paste
Columns("R:R").Select
Range("R1").Activate
Application.CutCopyMode = False
Selection.ClearContents
Columns("A:A").Select
Selection.Copy
Columns("R:R").Select
ActiveSheet.Paste
Columns("S:S").Select
Application.CutCopyMode = False
Selection.Copy
Columns("A:A").Select
ActiveSheet.Paste
Columns("S:S").Select
Application.CutCopyMode = False
Selection.ClearContents
Dim PWsht As Worksheet, PBlk As Range, PCll As Range, PFRw As Range
Dim AWsht As Worksheet, ABlk As Range, AFRw As Range, AOfsR As Long
Dim i As Long
' definice bloku
Set PWsht = ActiveWorkbook.Worksheets("Import") ' list
Set PFRw = PWsht.Range("a1:r1") ' prvni radek
Set AWsht = ActiveWorkbook.Worksheets("Klienti")
Set AFRw = AWsht.Range("a1:r1")
' blok zaznamu na listu prepis
With PWsht
If Len(.Range("a1").Value) > 0 Then
' pocet radku obsahujicich zaznamy na listu prepis
i = 0
For Each PCll In .Range("a1:a500").Cells
If Len(PCll.Value) > 0 Then i = i + 1
Next PCll
' definovat blok zaznamu na listu prepis
Set PBlk = PFRw.Resize(i, PFRw.Columns.Count)
' nastavit ofset pro prvni volny radek na listu archiv
With AWsht
If Len(.Range("a1").Value) = 0 Then
Set ABlk = AFRw
Else
Set ABlk = .Range("A1:R" & .Cells(1, 1).End(xlDown).Row)
End If
AOfsR = ABlk.Rows.Count ' ofset prvniho volneho radku
End With
' prenest zaznamy z listu prepis na list archiv
AFRw.Resize(i, AFRw.Columns.Count).Offset(AOfsR, 0).Value = PBlk.Value
Else
MsgBox "Na listu prepis nejsou zaznamy k prevodu do archivu"
End If
End With
' odstranit objektove promenne
Set PWsht = Nothing
Set PBlk = Nothing
Set PCll = Nothing
Set PFRw = Nothing
Set AWsht = Nothing
Set ABlk = Nothing
Set AFRw = Nothing
End With
End Sub
citovat
Application.ScreenUpdating = False
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;\\Freenas\Hdd1\Excell\dataexport.csv", Destination:=Range("Import!$A$1") _
)
.Name = "dataexport"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1250
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
Range("C:C,D:D,P:P,Q:Q,R:R").Select '+++++++++++++++++++++++++++++++Vybere sloupce C:D,smaže obsah bunek a odstraní sloupce
Selection.ClearContents
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select '+++++++++++++++++++++++++++++++Vybere B sloupec a nastaví formát datumu
Selection.NumberFormat = "m/d/yyyy"
Columns("R:R").Select '++++++++++++++++++++++++++++++++přehození prvního a posledního sloupce
Range("R1").Activate
Selection.Copy
Columns("S:S").Select
Range("S1").Activate
ActiveSheet.Paste
Columns("R:R").Select
Range("R1").Activate
Application.CutCopyMode = False
Selection.ClearContents
Columns("A:A").Select
Selection.Copy
Columns("R:R").Select
ActiveSheet.Paste
Columns("S:S").Select
Application.CutCopyMode = False
Selection.Copy
Columns("A:A").Select
ActiveSheet.Paste
Columns("S:S").Select
Application.CutCopyMode = False
Selection.ClearContents
Dim PWsht As Worksheet, PBlk As Range, PCll As Range, PFRw As Range
Dim AWsht As Worksheet, ABlk As Range, AFRw As Range, AOfsR As Long
Dim i As Long
' definice bloku
Set PWsht = ActiveWorkbook.Worksheets("Import") ' list
Set PFRw = PWsht.Range("a1:r1") ' prvni radek
Set AWsht = ActiveWorkbook.Worksheets("Klienti")
Set AFRw = AWsht.Range("a1:r1")
' blok zaznamu na listu prepis
With PWsht
If Len(.Range("a1").Value) > 0 Then
' pocet radku obsahujicich zaznamy na listu prepis
i = 0
For Each PCll In .Range("a1:a500").Cells
If Len(PCll.Value) > 0 Then i = i + 1
Next PCll
' definovat blok zaznamu na listu prepis
Set PBlk = PFRw.Resize(i, PFRw.Columns.Count)
' nastavit ofset pro prvni volny radek na listu archiv
With AWsht
If Len(.Range("a1").Value) = 0 Then
Set ABlk = AFRw
Else
Set ABlk = .Range("A1:R" & .Cells(1, 1).End(xlDown).Row)
End If
AOfsR = ABlk.Rows.Count ' ofset prvniho volneho radku
End With
' prenest zaznamy z listu prepis na list archiv
AFRw.Resize(i, AFRw.Columns.Count).Offset(AOfsR, 0).Value = PBlk.Value
Else
MsgBox "Na listu prepis nejsou zaznamy k prevodu do archivu"
End If
End With
' odstranit objektove promenne
Set PWsht = Nothing
Set PBlk = Nothing
Set PCll = Nothing
Set PFRw = Nothing
Set AWsht = Nothing
Set ABlk = Nothing
Set AFRw = Nothing
End With
End Sub
citovat
RSS nejnovější články