Problem z obszarem danych

0

Cześć,

stworzyłam kod który ma na celu

  1. wybór arkusza z folderu
  2. skopiowanie z niego wybranych danych do poszczególnych kolumn
    To jakie dane zostaną skopiowane zależy od dwóch rzeczy - od treści znajdującej się w arkuszu do którego będą kopiowane dane: wsCopyTo.Range("B17") = "K 01" oraz od treści w arkuszu z którego kopiuję - czy jest tam w kolumnie obok symbol k czy m.

Niestety makro wyświetla mi komunikat Run-time error 13 Type mismatch. Wcześniej, przed wprowadzeniem funkcji if wszystko działało... jak naprawić te błędy?

Sub PobierzDane()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet

Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet

'-------------------------------------------------------------
'Open file with data to be copied
Dim str_folder As String

ChDir "C:\Users\LEN\Desktop"
vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", False)

'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
    Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
End If

'--------------------------------------------------------------
'Copy Range

wsCopyFrom.Range("E3").Copy
wsCopyTo.Range("A5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False


wsCopyFrom.Range("G4").Copy
wsCopyTo.Range("A7").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("G4").Copy
wsCopyTo.Range("H5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("C2").Copy
wsCopyTo.Range("I5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        

If wsCopyTo.Range("B17") = "K 01" And wsCopyFrom.Range("F10:F29") = "K" Then
wsCopyFrom.Range("D10:D29").Copy
wsCopyTo.Range("G32:G53").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False

   wsCopyFrom.Range("E10:E29").Copy
   wsCopyTo.Range("H32:H53").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False

   wsCopyFrom.Range("B10:B29").Copy
   wsCopyTo.Range("A32:A53").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        

Application.CutCopyMode = False

End If

If wsCopyTo.Range("B17") = "M 02" And wsCopyFrom.Range("F10:F29") = "M" Then
wsCopyFrom.Range("D10:D29").Copy
wsCopyTo.Range("G32:G53").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False

   wsCopyFrom.Range("E10:E29").Copy
   wsCopyTo.Range("H32:H53").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False

   wsCopyFrom.Range("B10:B29").Copy
   wsCopyTo.Range("A32:A53").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        

Application.CutCopyMode = False

End If

'Close file that was opened
wbCopyFrom.Close SaveChanges:=False

End Sub

0

Tak, dzięki za zainteresowanie, problem już rozwiązany :)
Mam teraz inny problem, i nie jestem pewna jak go rozwiązać. Otóż kod w obecnej formie wygląda tak:

Sub PobierzDane()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet

Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet

'-------------------------------------------------------------
'Open file with data to be copied
Dim str_folder As String

ChDir "C:\Users\LEN\Desktop\"
vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", False)

'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
    Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
End If

'--------------------------------------------------------------
'Copy Range

wsCopyFrom.Range("E3").Copy
wsCopyTo.Range("A5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wsCopyTo.Range("A5:B7").Merge
        

If wsCopyFrom.Range("G4") = "" Then
  wsCopyFrom.Range("G5").Copy
wsCopyTo.Range("A8").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wsCopyTo.Range("A8:B9").Merge
        

Else
  wsCopyFrom.Range("G4").Copy
wsCopyTo.Range("B8").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wsCopyTo.Range("A8:B9").Merge
        
End If


If wsCopyFrom.Range("G4") = "" Then
  wsCopyFrom.Range("G5").Copy
wsCopyTo.Range("H5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
    Else
  wsCopyFrom.Range("G4").Copy
wsCopyTo.Range("H5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        
End If


 wsCopyFrom.Range("C2").Copy
wsCopyTo.Range("I5").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        

'-----------------------------------------------------------------
'If
Dim mkrange As String
Dim prange As String

If wsCopyTo.Range("A14").Value = "Krojownia 01" Then
mkrange = "K"
ElseIf wsCopyTo.Range("A14").Value = "Montaż 02" Then
mkrange = "M"
prange = "P"
End If

lastRow = Range("B10").End(xlDown).Row
j = 31
For I = 10 To lastRow

If wsCopyFrom.Range("F" & I).Value = mkrange Or wsCopyFrom.Range("F" & I).Value = prange Then
If IsEmpty(Range("A" & j).Value) = True Then
    wsCopyFrom.Range("B" & I).Copy
    wsCopyTo.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    wsCopyFrom.Range("D" & I & ":E" & I).Copy
    wsCopyTo.Range("G" & j & ":H" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    j = j + 1
End If
End If

Next

Application.ScreenUpdating = False

'Close file that was opened
wbCopyFrom.Close SaveChanges:=False

'doklejanie podpisów

'Range("A89:M91").Select

'Selection.Copy
'ActiveWindow.SmallScroll Down:=-33
'Range("A56:M58").Select
'ActiveSheet.Paste
'ActiveWindow.SmallScroll Down:=3

End Sub

Chciałabym jednak zmodyfikować pętlę, tak aby skopiowane dane były wklejane w konkretne - tylko puste - obszary arkusza, a nie jeden po drugim. Niestety to co napisałam nie działa :( Czy ktoś mógłby mi podpowiedzieć, gdzie robię błąd, ewentualnie jak zmodyfikować kod?

0

Hej,
a możesz podać przykład w załączniku jak to ma mniej więcej działać ?? Łatwiej będzie (i szybciej) napisać kod (lub poprawić) na podstawie załącznika...

0
hurgadion napisał(a):

Hej,
a możesz podać przykład w załączniku jak to ma mniej więcej działać ?? Łatwiej będzie (i szybciej) napisać kod (lub poprawić) na podstawie załącznika...

Hej,

wysyłam załącznik, który mam nadzieję coś wyjaśni, choć nie jestem pewna czy do końca. W razie czego odpowiem na pytania :) zaciągam dane z konkretnego folderu na komputerze, z którego wybieram arkusz Excel. Dane mają ten sam identyczny schemat: kolumna A - nazwa, którą ma mi skopiować do kolumny A w moim pliku. Kolumna D - jednostka miary którą ma skopiować do kolumny B i kolumna E - norma brutto, którą ma skopiować do kolumny C. Dane są kopiowane w zależności od wartości w polu A14 (krojownia lub montaż) w pliku z załącznika oraz wartości w kolumnie F (K lub M/P) w pliku wybieranym, z którego zaciągam dane.

0
KasiaR napisał(a):
hurgadion napisał(a):

Hej,
a możesz podać przykład w załączniku jak to ma mniej więcej działać ?? Łatwiej będzie (i szybciej) napisać kod (lub poprawić) na podstawie załącznika...

Hej,

wysyłam załącznik, który mam nadzieję coś wyjaśni, choć nie jestem pewna czy do końca. W razie czego odpowiem na pytania :) zaciągam dane z konkretnego folderu na komputerze, z którego wybieram arkusz Excel. Dane mają ten sam identyczny schemat: kolumna A - nazwa, którą ma mi skopiować do kolumny A w moim pliku. Kolumna D - jednostka miary którą ma skopiować do kolumny B i kolumna E - norma brutto, którą ma skopiować do kolumny C. Dane są kopiowane w zależności od wartości w polu A14 (krojownia lub montaż) w pliku z załącznika oraz wartości w kolumnie F (K lub M/P) w pliku wybieranym, z którego zaciągam dane.

Wprowadziłam przed chwilą zmianę - dodałam instrukcję select case... niestety dalej nie działa poprawnie - tj. kopiowanie przestaje działać w wierszu 56.

'-----------------------------------------------------------------
  'If
   Dim mkrange As String
   Dim prange As String
   


   If wsCopyTo.Range("A14").Value = "Krojownia 01" Then
    mkrange = "K"
   ElseIf wsCopyTo.Range("A14").Value = "Montaż 02" Then
   mkrange = "M"
   prange = "P"
   End If
   
  
     
lastRow = Range("B10").End(xlDown).Row
j = 31
For I = 10 To lastRow
Select Case j
Case 27, 28, 29, 30, 56, 57, 58, 59, 60, 61, 62, 63, 89, 90, 91, 92, 93, 94, 95, 96
Case Else
    If wsCopyFrom.Range("F" & I).Value = mkrange Or wsCopyFrom.Range("F" & I).Value = prange Then
        wsCopyFrom.Range("B" & I).Copy
        wsCopyTo.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wsCopyFrom.Range("C" & I).Copy
        wsCopyTo.Range("F" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wsCopyFrom.Range("D" & I & ":E" & I).Copy
        wsCopyTo.Range("G" & j & ":H" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        j = j + 1
    End If
    
    End Select
    

    
Next

   Application.ScreenUpdating = False

    
    
    'Close file that was opened
    wbCopyFrom.Close SaveChanges:=False
0

OK,
żeby nie tracić czasu... na rozgryzanie kodu, to jest zawsze najtrudniejsze... podaj może w trzecim arkuszu fragment ściąganych danych... z w czwartym arkuszu efekt oczekiwany... ja to sobie porównam z pierwszymi dwoma arkuszami, i postaram się znaleźć to rozwiązanie... a Ty sobie po prostu je potem zmodyfikujesz... :)

0

Super, wysyłam wszystko w załączniku.

1

OK...
Na początek może przetestuj to:

Sub sciagnij_dane_w_Arkuszu_Efekt_oczekiwany()
Dim i&, j&, x&

x = 1
With Worksheets("Przykładowe dane do ściągnięcia")
   For j = 1 To 3
      For i = 1 To 25
         x = x + 1
         Cells(33 * j - 3 + i, 1).Value = .Cells(x, 2).Value
         Cells(33 * j - 3 + i, 7).Value = .Cells(x, 4).Value
         Cells(33 * j - 3 + i, 8).Value = .Cells(x, 5).Value
         Cells(33 * j - 3 + i, 9).Value = .Cells(x, 6).Value
      Next i
   Next j
End With
End Sub

Jakoś tam makro porządkuje dane, ale nie jestem pewien czy nie trzeba użyć jakiejś instrukcji warunkowej... bo w przykładowych danych np. znika "O" i nie ma wszystkich (chyba) danych, przetestuj ten kod (we właściwym arkuszu)... i napisz co na ten temat myślisz, pzdr... :)

0
hurgadion napisał(a):

OK...
Na początek może przetestuj to:

Sub sciagnij_dane_w_Arkuszu_Efekt_oczekiwany()
Dim i&, j&, x&

x = 1
With Worksheets("Przykładowe dane do ściągnięcia")
   For j = 1 To 3
      For i = 1 To 25
         x = x + 1
         Cells(33 * j - 3 + i, 1).Value = .Cells(x, 2).Value
         Cells(33 * j - 3 + i, 7).Value = .Cells(x, 4).Value
         Cells(33 * j - 3 + i, 8).Value = .Cells(x, 5).Value
         Cells(33 * j - 3 + i, 9).Value = .Cells(x, 6).Value
      Next i
   Next j
End With
End Sub

Jakoś tam makro porządkuje dane, ale nie jestem pewien czy nie trzeba użyć jakiejś instrukcji warunkowej... bo w przykładowych danych np. znika "O" i nie ma wszystkich (chyba) danych, przetestuj ten kod (we właściwym arkuszu)... i napisz co na ten temat myślisz, pzdr... :)

Dzięki serdeczne za pomoc!!! :) Przetestowałam, działa, ale faktyczne musi być warunek, coś podobnego co było w kodzie pierwotnym, bo inaczej miesza mi dane i wkleja również te, których nie potrzebuję. To musi być warunek oparty na wartościach K i M/P.

Teraz kod wygląda tak (ale nie działa mi tak jak trzeba :( :

'If
Dim mkrange As String
Dim prange As String

If wsCopyTo.Range("A14").Value = "Krojownia 01" Then
mkrange = "K"
ElseIf wsCopyTo.Range("A14").Value = "Montaż 02" Then
mkrange = "M"
prange = "P"
End If

'---------------
Dim i&, j&, x&

If wsCopyTo.Range("A14").Value = "Krojownia 01" Then
mkrange = "K"
ElseIf wsCopyTo.Range("A14").Value = "Montaż 02" Then
mkrange = "M"
prange = "P"
End If

x = 1
With wsCopyFrom
For j = 1 To 3
For i = 1 To 25
x = x + 1
If wsCopyFrom.Range("F" & x).Value = mkrange Or wsCopyFrom.Range("F" & x).Value = prange Then
wsCopyTo.Cells(33 * j - 3 + i, 1).Value = wsCopyFrom.Cells(x, 2).Value
wsCopyTo.Cells(33 * j - 3 + i, 7).Value = wsCopyFrom.Cells(x, 4).Value
wsCopyTo.Cells(33 * j - 3 + i, 8).Value = wsCopyFrom.Cells(x, 5).Value
wsCopyTo.Cells(33 * j - 3 + i, 9).Value = wsCopyFrom.Cells(x, 6).Value
End If
Next i
Next j
End With

0

Kurcze, nie bardzo rozumiem... Ponieważ w Arkuszu "Przykładowe dane do ściągnięcia" w kolumnie F występuje tylko "M"... Czy mogłabyś przygotować jeszcze jeden plik z trochę bardziej zróżnicowanymi danymi... i wytłumaczyć krok po kroku jak ma to działać... ponieważ ciężko mi to w ogólnej sytuacji ogarnąć... a Tobie jest zdecydowanie łatwiej... Jak podasz mi dobrze opisany przykład, to napisanie kodu raczej nie powinno stanowić problemu... :)

0
hurgadion napisał(a):

Kurcze, nie bardzo rozumiem... Ponieważ w Arkuszu "Przykładowe dane do ściągnięcia" w kolumnie F występuje tylko "M"... Czy mogłabyś przygotować jeszcze jeden plik z trochę bardziej zróżnicowanymi danymi... i wytłumaczyć krok po kroku jak ma to działać... ponieważ ciężko mi to w ogólnej sytuacji ogarnąć... a Tobie jest zdecydowanie łatwiej... Jak podasz mi dobrze opisany przykład, to napisanie kodu raczej nie powinno stanowić problemu... :)

Już tłumaczę, moje zaniedbanie, że o tym nie wspomniałam. Jeśli chodzi o kolumnę F w arkuszu, z którego kopiujemy dane, to mamy tam:

  • albo literę K, co odpowiada polu A14 w arkuszu do którego kopiujemy dane, w którym znajduje się napis: Krojownia 01
    albo literę M lub P, co odpowiada polu A14 w arkuszu do którego kopiujemy dane, w którym znajduje się napis: Montaż 02.
    Na podstawie tego można zatem napisać instrukcję warunku odnośnie zaciągania danych. Jeżeli w A14 jest napis Krojownia 01, to kopiuje tylko dane z literą K. Jeżeli w A14 mamy Montaż 02, to kopiuje tylko dane z literami P lub M z kolumny F.
    W załączniku arkusz ze zróżnicowanymi danymi :)
0

Nie, tylko te 3 :)

0

Spróbuj odpalić i przetestuj na paru, różnych przykładach...

Sub sciagnij_dane_w_Arkuszu_Efekt_oczekiwany2()
Dim i&, j&, x&, zz As String, w As Boolean

x = 9
zz = "MP"
If Left(Cells(14, 1).Value, 1) = "K" Then zz = "K"

With Worksheets("Przykładowe dane do ściągnięcia")
   For j = 1 To 3
      For i = 1 To 25
         While w = False
           x = x + 1
           If zz Like "*" & .Cells(x, 6).Value & "*" Then w = True
           If .Cells(x, 6).Value = "" Then w = True
         Wend
         Cells(33 * j - 3 + i, 1).Value = .Cells(x, 2).Value
         Cells(33 * j - 3 + i, 7).Value = .Cells(x, 4).Value
         Cells(33 * j - 3 + i, 8).Value = .Cells(x, 5).Value
         Cells(33 * j - 3 + i, 9).Value = .Cells(x, 6).Value
         w = False
      Next i
   Next j
End With
End Sub

Jeżeli ilość danych będzie podobna, oraz arkusze do wpisywania będą miały taki schemat jak podany, powinno wystarczyć... Jeżeli ni, to będziemy wprowadzać pewne modyfikacje kodu... :)

1 użytkowników online, w tym zalogowanych: 0, gości: 1