Łączenie wielu zakresów za pomocą vba

Question

Mam nadzieję, że ktoś może mi pomóc z moim problemem. Zasadniczo, mam wiele zakresów, które muszę łączyć niezależnie i umieszczać wartości połączonych zakresów w różnych komórkach. Na przykład chcę: połączyć wartości w zakresie A1: A10 i umieścić wynik w F1 , a następnie chcę połączyć zakres B1: B10 i umieścić wynik w F2 , a następnie chcę połączyć zakres C1: C10 i umieścić wynik w F3 itp.

Próbowałem użyć następującego makra. Jednak utknąłem; to, co wydaje się robić makro, to łączenie zakresu A1: A10, a następnie umieszczanie wyników w F1 (co jest tym, czego chcę). Jednak przechowuje również informacje z pierwszego połączenia w pamięci, tak że kiedy wykonuje następną konkatenację, w komórce F2 łączą się połączone wyniki F1 i F2.

Próbowałem przeszukiwać wiele forów, ale ponieważ jest to kod, który sam napisałem, nie mogę znaleźć rozwiązania, jestem pewien, że jest to powszechny problem i że robię coś źle, prawdopodobnie nie ustawiam poprawnie zmiennej .

Z góry dzięki za pomoc,

Sub concatenate() 

    Dim x As String 
    Dim Y As String 

For m = 2 To 5 

    Y = Worksheets("Variables").Cells(m, 5).Value 

'Above essentially has the range information e.g. a1:a10 in sheet variables 

For Each Cell In Range("" & Y & "") 'i.e. range A1:A10 
    If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached 
    x = x & Cell.Value & "," 'this provides the concatenated cell value 
Next 

Line1: 

ActiveCell.Value = x 

ActiveCell.Offset(1, 0).Select 

Next m 

End Sub 

Answer 1

... Chciałbym to zrobić bardzo różnie ... Dlaczego nie stworzyć funkcję wzdłuż linii:

Function ConcatMe(Rng As Range) As String 

Dim cl As Range 

    ConcatMe = "" 

    For Each cl In Rng 
     ConcatMe = ConcatMe & cl.Text 
    Next cl 

End Function 

a potem po prostu na przykład ustaw F1 = ConcatMe(A1:A10) lub wpisz kod, aby przypisać funkcję komórkom, które chcesz ...

Lub, jak wspomniał @KazJaw w swoim komentarzu, po prostu ustaw x="" przed ponownym zapętleniem.

Mam nadzieję, że to pomoże

Answer 2

Oto mój ConcatenateRange. To pozwala na dodanie seperatora, jeśli chcesz. Jest zoptymalizowany do obsługi dużych zakresów, ponieważ działa poprzez zrzucanie danych w tablicy wariantów i pracę z nią w VBA.

będzie go używać tak:

=ConcatenateRange(A1:A10) 

kodu:

Function ConcatenateRange(ByVal cell_range As range, _ 
        Optional ByVal seperator As String) As String 

Dim cell As range 
Dim newString As String 
Dim cellArray As Variant 
Dim i As Long, j As Long 

cellArray = cell_range.Value 

For i = 1 To UBound(cellArray, 1) 
    For j = 1 To UBound(cellArray, 2) 
     If Len(cellArray(i, j)) <> 0 Then 
      newString = newString & (seperator & cellArray(i, j)) 
     End If 
    Next 
Next 

If Len(newString) <> 0 Then 
    newString = Right$(newString, (Len(newString) - Len(seperator))) 
End If 

ConcatenateRange = newString 

End Function 

Answer 3

Dzięki za wszystko chłopaki, dla mojego celu zmodyfikowałem swoje sugestie i zmienione mojego kodu, ponieważ nie całkiem pasuje do zgrabnej funkcji, ponieważ potrzebowałem jej, by była bardziej dynamiczna. Zobacz mój kod poniżej. Robi dokładnie to, czego potrzebuję.

Sub concatenate() 

Dim x As String 
Dim Y As String 

For Q = 1 To 10 'This provides a column reference to concatenate - Outer For statement 
For T = 1 To 10 'This provides a rows reference to concatenate - Inner for statement 

For Each Cell In Cells(T, Q) 'provides rows and column reference 
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached 
x = x & Cell.Value & "," 'This provides the concatenated cell value and comma separator 
Next ' this loops the range 

Next T 'This is the inner loop which dynamically changes the number of rows to loop until a blank cell is reached 

Line1: 
On Error GoTo Terminate 'Terminates if there are less columns (max 10) to concatenate 

ActiveCell.Value = Mid(x, 1, Len(x) - 1) 'This basically removes the last comma from the last concatenated cell e.g. you might get for a range 2,3,4, << this formula removes the last comma to 
'give 2,3,4 

ActiveCell.Offset(1, 0).Select 'Once the concatenated result is pasted into the cell this moves down to the next cell, e.g. from F1 to F2 

x = "" 'The all important, clears x value after finishing concatenation for a range before moving on to another column and range 


Next Q 'After one range is done the second column loop kicks in to tell the macro to move to the next column and begin concatenation range again 

Terminate: 'error handler 
End Sub 

Answer 4

jest podobny do pomysłu zamieszczonego tutaj. Jednak używam a dla każdej pętli zamiast konfiguracji z zagnieżdżonymi pętlami.

Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = "") 

ConcRange = vbNullString 

Dim rngCell As Range 

For Each rngCell In myRange 
    If ConcRange = vbNullString Then 
     If Not rngCell.Value = vbNullString Then 
      ConcRange = CStr(rngCell.Value) 
     End If 
    Else 
     If Not rngCell.Value = vbNullString Then 
      ConcRange = ConcRange & Seperator & CStr(rngCell.Value) 
     End If 
    End If 
Next rngCell 


End Function 

To, jak sądzę byłoby szybciej niż tablicy utworzonej jako nowa tablica nie jest tworzony za każdym razem ta funkcja działa.

Answer 5

Bardzo prosty brat, Wygląda na Excel. Nie potrzeba żadnej uciążliwej formuły ani VBA.

Po prostu skopiuj wszystkie komórki, które chcesz połączyć i wkleić do notatnika.Teraz wystarczy wybrać przestrzeń między liniami/kolumnami (faktycznie jest to przestrzeń TAB) i znaleźć i zastąpić ją. Gotowe. Wszystkie komórki są połączone. Teraz po prostu skopiuj i wklej go w kolumnie i po prostu zweryfikuj ... To :) Ciesz się.

Proponuję używać Notepad ++ do tego :) Koodos

Vimarsh Ph. D. Zakład Biotech. /

Answer 6

Tuż przed Następny m wkładki prostym stwierdzeniem: x = "" - KazimierzJawor 08 kwietnia '13 w 20:43

zajęło mi kilka minut, aby zauważyć tę odpowiedź była pod uwag: p

Answer 7

Rozwiązanie @ Issun nie akceptuje danych wyjściowych ze wzoru tablicy arkusza roboczego jako argumentu dla parametru 'cell_range'. Ale drobna modyfikacja kodu @ Issun naprawia to. Dodałem również kontrolę, która ignoruje każdą komórkę, której wartość to FALSE.

Function ConcatenateRange(_ 
     ByVal cellArray As Variant, _ 
     Optional ByVal seperator As String _ 
      ) As String 

    Dim cell As Range 
    Dim newString As String 
    Dim i As Long, j As Long 

    For i = 1 To UBound(cellArray, 1) 
     For j = 1 To UBound(cellArray, 2) 
      If Len(cellArray(i, j)) <> 0 Then 
       If (cellArray(i, j) <> False) Then 
        newString = newString & (seperator & cellArray(i, j)) 
       End If 
      End If 
     Next 
    Next 

    If Len(newString) <> 0 Then 
     newString = Right$(newString, (Len(newString) - Len(seperator))) 
    End If 

    ConcatenateRange = newString 

End Function 

Na przykład

A  B  (<COL vROW) 
------ ------ ----------------- 
one  1   3 
two  1   4 
three 2   5 
four 2   6 

Wejść komórki C1 poniższy wzór nacisnąć klawisze Ctrl + ENTER do przechowywania wzoru jako preparat tablicy:

{=ConcatenateRange(IF(B3:B6=1,A3:A6),CHAR(10))} 

Answer 8

szukałem dalszego zobacz, czy istnieje lepszy sposób pisania funkcji łączonej i znaleźć to. Wydaje się, że wszyscy mamy tę samą zasadę działania dla tej funkcji. Więc jest ok.

Ale moja funkcja jest inna, ponieważ może przyjmować wiele parametrów, w połączeniu zakresów, tekstów i liczb.

Zakładam, że ogranicznik jest obowiązkowy, więc jeśli go nie potrzebuję, wstawiam "" jako ostatni parametr.

Zakładam również, że pustych komórek nie należy pomijać. To jest powód, dla którego chcę, aby funkcja przyjmowała wiele parametrów, więc mogę łatwo pominąć te, których nie chcę w konkatenacji.

Przykład zastosowania:

=JoinText(A1:D2,F1:I2,K1:L1,";")

Można również użyć razem tekst i numer spośród parametrów:

=JoinText(A1:D2,123,F1:I2,K1:L1,"PQR",";")

Chciałbym usłyszeć jakieś uwagi lub sugestie gdzie można ulepszyć.

Oto kod.

Public Function JoinText(ParamArray Parameters() As Variant) As String 
    Dim p As Integer, c As Integer, Delim As String 

    Delim = Parameters(UBound(Parameters)) 

    For p = 0 To UBound(Parameters) - 1 
     If TypeName(Parameters(p)) = "Range" Then 
      For c = 1 To Parameters(p).Count 
       JoinText = JoinText & Delim & Parameters(p)(c) 
      Next c 
     Else 
      JoinText = JoinText & Delim & Parameters(p) 
     End If 
    Next p 

    JoinText = Replace(JoinText, Delim, "", , 1, vbBinaryCompare) 

End Function