VBA Code to paste Data in specific Row in another Workbook, depending on the Number in Column 43 of the copied Row

[Meaculpa]

My Problem seems simple but i'm just not able to solve it alone. My VBA Code copies Data, based on a Filter and past it to another Workbook, starting in Row 1. What i want to change now is, that the Code checks the Number in Column 43 (AQ) from every Row he copies and paste the Row into the Row that matches that Number. For Example: If the Number 7 stands in AQ than the Row should be pasted in row 7. If the Number 3 stands there, it should be pasted into Row 3. In between some Numbers are not included so it can be, that some Rows in between are staying empty.

My intially Code to Copy/Paste data, that worked, was this one.

Sub SG7Stundenplan()

SG7Stundenplan


Sheets("Gruppenplanung").Select
Columns.EntireColumn.Hidden = False
Range("A2").Select
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.Range("A2").AutoFilter Field:=19, Criteria1:="SG 7", Operator:=xlAnd
Rows("3:100").Select
Selection.Copy
Workbooks.Open "R:\BINplus\Langenthal\Stammgruppen\Stammgruppe 7\Stammgruppe 7_Unterrichtspläne Test.xlsm"
Worksheets("Stammdaten").Range("A1").PasteSpecial Paste:=xlPasteValues
Workbooks("Stammgruppe 7_Unterrichtspläne Test.xlsm").Close SaveChanges:=True


End Sub

I allready tried to create something new but i failed till now. Im pretty sure you need to copy the Rows singulary to put that trick off.

Sub SG7Stundenplan()

Dim Zelle As Range
Workbooks.Open "R:\BINplus\Langenthal\Stammgruppen\Stammgruppe 7\Stammgruppe 7_Unterrichtspläne Test.xlsm"
For Each Zelle In ThisWorkbook.Sheets("Gruppenplanung").UsedRange.Columns(19)
If Zelle.Text = "SG 7" Then
Zelle.EntireRow.Copy
Workbooks("Stammgruppe 7_Unterrichtspläne Test.xlsm").Worksheets("Stammdaten").Cells(Zelle.Offset(43 - Zelle.Column).Value, 1).PasteSpecial xlPasteValues
End If
Next
Workbooks("Stammgruppe 8_Unterrichtspläne Test.xlsm").Close True

End Sub

Thanks a lot for checking this Post and think about it. Your a great Community that allready helped me a lot.

Sincerely,

David from Switzerland

 

[HaHoBe]

Hi David,

maybe give the following code a try:

Sub SG7Stundenplan_mod()
'https://www.mrexcel.com/board/threads/vba-code-to-paste-data-in-specific-row-in-another-workbook-depending-on-the-number-in-column-43-of-the-copied-row.1213388/

Dim Zelle As Range
Dim wbZiel As Workbook        'workbook to open
Dim wsStamm As Worksheet      'worksheet to copy to
Dim wsGruPlan As Worksheet    'worksheet to copy from

Set wsGruPlan = ThisWorkbook.Sheets("Gruppenplanung")
Set wbZiel = Workbooks.Open("R:\BINplus\Langenthal\Stammgruppen\Stammgruppe 7\Stammgruppe 7_Unterrichtspläne Test.xlsm")
Set wsStamm = wbZiel.Worksheets("Stammdaten")

For Each Zelle In wsGruPlan.UsedRange.Columns(19)
  If Zelle.Text = "SG 7" Then
    Zelle.EntireRow.Copy
    wsStamm.Range("A" & Zelle.Offset(0, 24).Value).PasteSpecial xlPasteValues
  End If
Next
wbZiel.Close True

Set wsStamm = Nothing
Set wbZiel = Nothing
Set wsGruPlan = Nothing

End Sub

You could use the following code to directly get over the values instead of copying:

lngColumns = wsGruPlan.UsedRange.Columns.Count
'...
    wsStamm.Range("A" & Zelle.Offset(0, 24).Value).Resize(1, lngColumns).Value = _
        wsGruPlan.Cells(Zelle.Row, 1).Resize(1, lngColumns).Value

Ciao,
Hikger

 

[Meaculpa]

Hi Hikger

Thx a lot for your fast and helpful Answer. But for now, it still has the same Problems that I had. It doesn’t copy or pasts anything. Maybe I just didn’t found the right Sentences to describe my Problem or I made a Mistake.

So, the Idea would be that it Filters Columns S and copies all Rows who match those Conditions. Then they should get paste into the new Workbook, depending on the Number you can See in Column AQ. So, Number 1 in Row 1 Number 5 in Row 5 etc. If the Code would work correctly, the other Document would look like the second Picture I did send.

Excuse me for the Trouble i make you. English is not my native Language.

 

[HaHoBe]

Hi David,

English is not my native Language.

Neither it is mine.

You could choose Questions in Other Languages were you could post in German language. If you choose to do so you should leave a link to the new thread. If you prefer to stay in this thread maybe you post in both english as well as deutsch.

For the time being I will try to spot what you are after and why the code is not working as intended.

Ciao,
Holger

 

[Meaculpa]

Hi Holger

Well for that, we're both doing a pretty decent job in English.

Thanks for the Information. That's great to know for the Future.

I'm allready excited if you find anything and i'm also very Grateful for your Support. I will also do my best to find a Solution in the Meantime. Did I explain it understandable or do you need any further Informations?

Hopefully we here us soon

Kind regards,

David

 

[HaHoBe]

Hi David,

I changed some lines in the code and integrated AutoFilter. Please check and see if the code does what it´s supposed to do. Maybe use F8 to step through the code codeline by codeline and see what is happening in the workbook(s).

I didn´t use a different workbook but used a different sheet in the same book - just for my ease.

Sub SG7Stundenplan_mod2()

Dim Zelle As Range
Dim wbZiel As Workbook        'workbook to open
                              'Arbeitsmappe, die geöffnet werden soll
Dim wsStamm As Worksheet      'worksheet to copy to
                              'Tabelle, die die Daten aufnehmen soll
Dim wsGruPlan As Worksheet    'worksheet to copy from
                              'Tabelle, von der aus kopiert werden soll

'Tabelle befindet sich in dieser Arbeitsmappe, Objekt wird gesetzt
Set wsGruPlan = ThisWorkbook.Sheets("Gruppenplanung")

'Öffnen der Mappe und setzen von Objekten zur Mape und zur Zieltabelle
Set wbZiel = Workbooks.Open("R:\BINplus\Langenthal\Stammgruppen\Stammgruppe 7\Stammgruppe 7_Unterrichtspläne Test.xlsm")
Set wsStamm = wbZiel.Worksheets("Stammdaten")

If wsGruPlan.AutoFilterMode Then wsGruPlan.Range("A1").AutoFilter         'If any Autofilter applied will turn it off
                                                                          'schaltet einen existierend Autofilter aus
wsGruPlan.Rows("1:1").AutoFilter 19, "SG 7"                               'Set the header row in Row1 and choose S1 (Column 19)
                                                                          'with the criteria
                                                                          'Setzt einen Autofilter in Zeile 1 und legt für
                                                                          'Spalte S1 das Kriterium fest

'Loop through all visible cells in the data range after the filter has been used but only in Column 19
'Durchlaufen der sichtbaren Zellen im Datenbereich unterhalb der Überschriften in Spalte 19
For Each Zelle In wsGruPlan.Range("S2", wsGruPlan.Cells(wsGruPlan.Rows.Count, "S").End(xlUp)).SpecialCells(xlCellTypeVisible)
  Zelle.EntireRow.Copy
  'as we copied the entire row we use the equivalent row in the target sheet
  'da wir die gesamte Zeile kopieren, wählen wir die entsprechende Zeile in der Zieltabelle aus
  wsStamm.Rows(Zelle.Offset(0, 24).Value).EntireRow.PasteSpecial xlPasteValues
Next Zelle

wbZiel.Close True
If wsGruPlan.AutoFilterMode Then wsGruPlan.Range("A1").AutoFilter

Set wsStamm = Nothing
Set wbZiel = Nothing
Set wsGruPlan = Nothing

End Sub

Ciao,
Holger

 

[Meaculpa]

Hi Holger

WOW! That functioned. I just had to change Something in the Autofilter Part, the Rest worked as intended. No idea how to thank you. You made my Week.

I have just 2 Questions about your Code.
1. Question: Can i reduce the Rows he checks? So that it's not "End(xlUp))" anymore and only goes until Row 198?
2. Question: Where is the Codeline about the Column 43 (AQ), where he takes the Number for the Rows? Sorry maybe im blind. But it has to be somewhere, because it works

I post the small changed Code:

Sub SG8Stundenplan()

Dim Zelle As Range
Dim wbZiel As Workbook 'workbook to open
'Arbeitsmappe, die geöffnet werden soll
Dim wsStamm As Worksheet 'worksheet to copy to
'Tabelle, die die Daten aufnehmen soll
Dim wsGruPlan As Worksheet 'worksheet to copy from
'Tabelle, von der aus kopiert werden soll

'Tabelle befindet sich in dieser Arbeitsmappe, Objekt wird gesetzt
Set wsGruPlan = ThisWorkbook.Sheets("Gruppenplanung")

'Öffnen der Mappe und setzen von Objekten zur Mape und zur Zieltabelle
Set wbZiel = Workbooks.Open("R:\BINplus\Langenthal\Stammgruppen\Stammgruppe 7\Stammgruppe 8_Unterrichtspläne Test.xlsm")
Set wsStamm = wbZiel.Worksheets("Stammdaten")

If wsGruPlan.AutoFilterMode Then wsGruPlan.Range("A2").AutoFilter 'If any Autofilter applied will turn it off
'schaltet einen existierend Autofilter aus
wsGruPlan.Range("A2").AutoFilter Field:=19, Criteria1:="SG 7", Operator:=xlAnd 'Set the header row in Row1 and choose S1 (Column 19)
'with the criteria
'Setzt einen Autofilter in Zeile 1 und legt für
'Spalte S1 das Kriterium fest

'Loop through all visible cells in the data range after the filter has been used but only in Column 19
'Durchlaufen der sichtbaren Zellen im Datenbereich unterhalb der Überschriften in Spalte 19
For Each Zelle In wsGruPlan.Range("S3", wsGruPlan.Cells(wsGruPlan.Rows.Count, "S").End(xlUp)).SpecialCells(xlCellTypeVisible)
Zelle.EntireRow.Copy
'as we copied the entire row we use the equivalent row in the target sheet
'da wir die gesamte Zeile kopieren, wählen wir die entsprechende Zeile in der Zieltabelle aus
wsStamm.Rows(Zelle.Offset(0, 24).Value).EntireRow.PasteSpecial xlPasteValues
Next Zelle

wbZiel.Close True
If wsGruPlan.AutoFilterMode Then wsGruPlan.Range("A1").AutoFilter

Set wsStamm = Nothing
Set wbZiel = Nothing
Set wsGruPlan = Nothing

End Sub

Ciao,
David

 

[HaHoBe]

Hi David,

Can i reduce the Rows he checks? So that it's not "End(xlUp))" anymore and only goes until Row 198?

Feel free to do if you like, The code I used is dynamic and would take of any change in number of rows in the sheet. If you want to change the range to a static row you may use

For Each Zelle In wsGruPlan.Range("S3:S198").SpecialCells(xlCellTypeVisible)

Using SpecialCells makes it necessary to have at least 2 cells in the filtered area to make the code work flawlessly (here in Column S only in the data range).

Where is the Codeline about the Column 43 (AQ), where he takes the Number for the Rows?

This is the line of code

wsStamm.Rows(Zelle.Offset(0, 24).Value).EntireRow.PasteSpecial xlPasteValues

The number is taken from the starting cell in Column S (19) but go 0 rows down and 24 columns right to find the value in Column AQ (43).

Glad you could get the code to work.
Holger