Copy content from next columns and paste it in alternative ones

[vladimiratanasiu]

Hello!

I have two larger tables, referring to the activity scheduling from a firm. The first table presents a part of one, with employee scheduling from 18/03/2022 for the bakery department, distributed in the shifts 1-3. The second one has same data, including additionally some white columns where is recorded the working time of each employee. My question is how could I copy the content from the first table (coloured in with red, yellow and blue) and paste it automatically as is shown in the second table, alternating columns and ignoring the white ones for timekeeping? Thank you!

			18/3/2022
ZI SAPT.			vineri
SCHIMB			1	2	3
Paine	Planificare productie
	Numar echipa
	Echipa Permanenta	BR01		JECU EMIL	TRANDAFIR LILIANA
		BR02		MOLDOVEANU VIORICA	COZLOV VIOLETA
		BR03		DORCESCU ADINA
		BR05			HARAGA MARIUS
		BR06		CIORANU STEFAN	MUTIHAC AURICA
Paine - Cocator Patiserie	Planificare productie
	Numar echipa
	Echipa Permanenta	BR04	CORDON COSTEL	RADU VICTOR	PETRE TOMA
SUPORT BRUTARIE - LIBERE	Planificare productie
	Numar echipa
	Echipa Permanenta	SPBR1		PETRE ALEXANDRU
SUPORT BRUTARIE - LIBERE	Planificare productie
	Numar echipa
	Echipa Permanenta	SPBR2			GRADINARU MARIANA

																																																																				18/3/2022
ZI SAPT.																																																																				vineri
SCHIMB																																																																				1		2		3
	Planificat
Paine
																																																																				Pontaj - ore lucrate		Pontaj - ore lucrate		Pontaj - ore lucrate
	BR01																																																																					JECU EMIL	8	TRANDAFIR LILIANA	8
	BR02																																																																					MOLDOVEANU VIORICA	8	COZLOV VIOLETA	8
	BR03																																																																					DORCESCU ADINA	8
	BR05																																																																					0		HARAGA MARIUS	5.5
	BR06																																																																					CIORANU STEFAN	8	MUTIHAC AURICA	8
	BR04																																																																			CORDON COSTEL	8	RADU VICTOR	8	PETRE TOMA	8
																																																																						#N/A
																																																																						#N/A
																																																																						#N/A
	SPBR1																																																																					PETRE ALEXANDRU	8
	SPBR2																																																																					0		GRADINARU MARIANA	8

 

[airforceone]

Test the below code if its satisfy your need also included test workbook based on the above given sample vladimiratanasiu Workbook

Sub vladimiratanasiu()
    
    Dim LastRow As Long
    Dim SourceSHT As Worksheet, TargetSHT As Worksheet
    Dim cTr As Integer, i As Integer

Application.ScreenUpdating = False

    LastRow = Range("C" & Rows.Count).End(xlUp).Row
    
    Set SourceSHT = Sheets("PAGE01")
    Set TargetSHT = Sheets("PAGE02")

    i = 7
    Do While i <= LastRow
        cTr = 7
        If IsEmpty(Cells(i, 3)) Then
        Else
            Do While cTr <= LastRow
                If SourceSHT.Range("C" & i) = TargetSHT.Range("B" & cTr) Then
                    TargetSHT.Range("BQ" & cTr).Value = SourceSHT.Range("D" & i).Value
                    TargetSHT.Range("BS" & cTr).Value = SourceSHT.Range("E" & i).Value
                    TargetSHT.Range("BU" & cTr).Value = SourceSHT.Range("F" & i).Value
                End If
                cTr = cTr + 1
            Loop
        End If
        i = i + 1
    Loop
    
Application.ScreenUpdating = True

End Sub

 

[vladimiratanasiu]

Thank you very much for your answer!

I tested your macro and it runs very well in a single workbook. However, my tables are placed in two different larger workbooks (see Programare noua.xlsx and Pontaj linii productie.xlsx). The book Programere noua contains sheet Programere personal, which is source of data for the book Pontaj linii productie. The table from source sheet is structured on production departments (e.g. Rademaker, Fritsch, Salam de biscuiti, etc.), team ID codes (e.g. RA01-RA22, FR01-FR18, PR01-PR05 etc.), days (30/01/2022 - 31/01/2023) and shifts (1,2 and 3), all of them within a single sheet. In the destination book Pontaj linii productie, information from the source book are divided in individual sheets. Each sheet corresponds to a field from the source table, allocated for a production department (e.g. sheet Rademaker - field C7-ALZ28 from the source workbook ; sheet Fritsch- field C32-ALZ49 etc). Distinctly, in the book Pontaj linii productie all tables of departments' sheets have an additional column added to each shift, to be recorded the worked hours of every employee from that shift. Both the source and the destination table (s) are filled daily with new information, though keeping the same structure. Taking into consideration these additional data and also the attached workbooks, could you adjust the previous macro to run for the linked tables? I mention again that the activity data are updated daily during one year, so that I need the formula(s) / command(s) cover 365 days. If it can't be developed a single macro common for updating automatically all files of workbook Pontaj linii productie, maybe you could edit one whose internal references could can be adjusted for each file individually, resulting as many macros as sheets are. Thank you!

 

[airforceone]

I hope this helps, kindly recode to your liking....
since your Destination workbook has too many link/formula that needs to process first. what I did is to address your concern on the root level ie. copying from one workbook to another when conditions are met (1. same ID code and 2. Cell not empty) based on that condition check sample Files and code if satisfy your need (Download Zip File) 2 Files, one Macro Enabled Workbook and the second is the mystical Destination workbook using the code below.... (again tested and working on my sample file)

for other sheet and columns you may want to experiment a little so as the code may evolve to your liking... hope this jumpstart your coding experience

Sub vladimiratanasiu()
    
Application.ScreenUpdating = False
    
    Dim SourceSHT As Worksheet, TargetSHT As Worksheet
    Dim TargetFileName As String, SourceFileName As String
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim cTr As Integer, i As Integer
    Dim LastRow As Long

    Set SourceSHT = ActiveSheet
    ActiveSheet.Select
    LastRow = Range("C" & Rows.Count).End(xlUp).Row

    TargetFileName = ActiveWorkbook.Path & "\TARGET.xlsx"
    Set wbTarget = Workbooks.Open(TargetFileName)
    Set TargetSHT = Sheets("Rademaker")

    i = 7
    Do While i <= LastRow
        cTr = 7
        If IsEmpty(SourceSHT.Range("C" & i)) Then
        Else
            Do While cTr <= LastRow
                If SourceSHT.Range("C" & i).Value = TargetSHT.Range("B" & cTr).Value Then
                    TargetSHT.Range("C" & cTr).Value = SourceSHT.Range("D" & i).Value
                    TargetSHT.Range("E" & cTr).Value = SourceSHT.Range("E" & i).Value
                    TargetSHT.Range("G" & cTr).Value = SourceSHT.Range("F" & i).Value
                End If
                cTr = cTr + 1
            Loop
        End If
        i = i + 1
    Loop
    
Application.ScreenUpdating = True

End Sub

 

[vladimiratanasiu]

I hope this helps, kindly recode to your liking....
since your Destination workbook has too many link/formula that needs to process first. what I did is to address your concern on the root level ie. copying from one workbook to another when conditions are met (1. same ID code and 2. Cell not empty) based on that condition check sample Files and code if satisfy your need (Download Zip File) 2 Files, one Macro Enabled Workbook and the second is the mystical Destination workbook using the code below.... (again tested and working on my sample file)

for other sheet and columns you may want to experiment a little so as the code may evolve to your liking... hope this jumpstart your coding experience

Sub vladimiratanasiu()
 
Application.ScreenUpdating = False
 
    Dim SourceSHT As Worksheet, TargetSHT As Worksheet
    Dim TargetFileName As String, SourceFileName As String
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim cTr As Integer, i As Integer
    Dim LastRow As Long

    Set SourceSHT = ActiveSheet
    ActiveSheet.Select
    LastRow = Range("C" & Rows.Count).End(xlUp).Row

    TargetFileName = ActiveWorkbook.Path & "\TARGET.xlsx"
    Set wbTarget = Workbooks.Open(TargetFileName)
    Set TargetSHT = Sheets("Rademaker")

    i = 7
    Do While i <= LastRow
        cTr = 7
        If IsEmpty(SourceSHT.Range("C" & i)) Then
        Else
            Do While cTr <= LastRow
                If SourceSHT.Range("C" & i).Value = TargetSHT.Range("B" & cTr).Value Then
                    TargetSHT.Range("C" & cTr).Value = SourceSHT.Range("D" & i).Value
                    TargetSHT.Range("E" & cTr).Value = SourceSHT.Range("E" & i).Value
                    TargetSHT.Range("G" & cTr).Value = SourceSHT.Range("F" & i).Value
                End If
                cTr = cTr + 1
            Loop
        End If
        i = i + 1
    Loop
 
Application.ScreenUpdating = True

End Sub

I hope this helps, kindly recode to your liking....
since your Destination workbook has too many link/formula that needs to process first. what I did is to address your concern on the root level ie. copying from one workbook to another when conditions are met (1. same ID code and 2. Cell not empty) based on that condition check sample Files and code if satisfy your need (Download Zip File) 2 Files, one Macro Enabled Workbook and the second is the mystical Destination workbook using the code below.... (again tested and working on my sample file)

for other sheet and columns you may want to experiment a little so as the code may evolve to your liking... hope this jumpstart your coding experience

Sub vladimiratanasiu()
 
Application.ScreenUpdating = False
 
    Dim SourceSHT As Worksheet, TargetSHT As Worksheet
    Dim TargetFileName As String, SourceFileName As String
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim cTr As Integer, i As Integer
    Dim LastRow As Long

    Set SourceSHT = ActiveSheet
    ActiveSheet.Select
    LastRow = Range("C" & Rows.Count).End(xlUp).Row

    TargetFileName = ActiveWorkbook.Path & "\TARGET.xlsx"
    Set wbTarget = Workbooks.Open(TargetFileName)
    Set TargetSHT = Sheets("Rademaker")

    i = 7
    Do While i <= LastRow
        cTr = 7
        If IsEmpty(SourceSHT.Range("C" & i)) Then
        Else
            Do While cTr <= LastRow
                If SourceSHT.Range("C" & i).Value = TargetSHT.Range("B" & cTr).Value Then
                    TargetSHT.Range("C" & cTr).Value = SourceSHT.Range("D" & i).Value
                    TargetSHT.Range("E" & cTr).Value = SourceSHT.Range("E" & i).Value
                    TargetSHT.Range("G" & cTr).Value = SourceSHT.Range("F" & i).Value
                End If
                cTr = cTr + 1
            Loop
        End If
        i = i + 1
    Loop
 
Application.ScreenUpdating = True

End Sub

Thank you for the above response!

I adjusted and tested your solution in a pair of simplified tables (see Pontaj linii productie-1.xlsx and Programare noua-1.xlsm), in order to eliminate the complicated formulas. It matches partially my problem, covering by results one day range only. In my sheets, it views date 31.03.2022 whereas the rest of them require new modifications of the macro. Giving the very long period concerned (one year), I should change daily the cells from the macro for each department. In these conditions, I wonder whether is any method for the macro to refer and process information, based on the horizontal continuous range of date and shift references (e.g. 21.02.2022-28.03.2022 - ranges EX1:FU1, EX3:FU3 - Source file Programare noua 1; ranges CI1:ED1, CI3:ED3 - Destination file Pontaj linii productie 1 ). They are some cross-cutting items that cover all year round and could bypass the daily necessary interventions. Or, similary, it could be considered references regarding employee (ID code) along the same period. Thank you !

 

[vladimiratanasiu]

I hope this helps, kindly recode to your liking....
since your Destination workbook has too many link/formula that needs to process first. what I did is to address your concern on the root level ie. copying from one workbook to another when conditions are met (1. same ID code and 2. Cell not empty) based on that condition check sample Files and code if satisfy your need (Download Zip File) 2 Files, one Macro Enabled Workbook and the second is the mystical Destination workbook using the code below.... (again tested and working on my sample file)

for other sheet and columns you may want to experiment a little so as the code may evolve to your liking... hope this jumpstart your coding experience

Sub vladimiratanasiu()
 
Application.ScreenUpdating = False
 
    Dim SourceSHT As Worksheet, TargetSHT As Worksheet
    Dim TargetFileName As String, SourceFileName As String
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim cTr As Integer, i As Integer
    Dim LastRow As Long

    Set SourceSHT = ActiveSheet
    ActiveSheet.Select
    LastRow = Range("C" & Rows.Count).End(xlUp).Row

    TargetFileName = ActiveWorkbook.Path & "\TARGET.xlsx"
    Set wbTarget = Workbooks.Open(TargetFileName)
    Set TargetSHT = Sheets("Rademaker")

    i = 7
    Do While i <= LastRow
        cTr = 7
        If IsEmpty(SourceSHT.Range("C" & i)) Then
        Else
            Do While cTr <= LastRow
                If SourceSHT.Range("C" & i).Value = TargetSHT.Range("B" & cTr).Value Then
                    TargetSHT.Range("C" & cTr).Value = SourceSHT.Range("D" & i).Value
                    TargetSHT.Range("E" & cTr).Value = SourceSHT.Range("E" & i).Value
                    TargetSHT.Range("G" & cTr).Value = SourceSHT.Range("F" & i).Value
                End If
                cTr = cTr + 1
            Loop
        End If
        i = i + 1
    Loop
 
Application.ScreenUpdating = True

End Sub

Hello!

I found the thread Copy Column data And Paste Into Every Other Column on a New Sheet, addressing quite similar my issue too. Could you analyze the last macro proposed as solution, and see whether / how can it be adjusted for my tables Programare noua-1.xlsm and Pontaj linii productie-1.xlsx in order to solve the problem? Thank you!

 

[airforceone]

try the code in the linked file
if it suits your need and try to manipulate it to your liking...

Option Explicit

Public cTr As Integer, NumberOfMerge As Integer, iCount As Integer
Public aIr As Integer, foRce As Integer, oNe As Integer
Public SourceSHT As Worksheet, TargetSHT As Worksheet, wsLoop As Worksheet, SuperSHT As Worksheet
Public wbSource As Workbook, wbTarget As Workbook
Public TargetFileName As String, SourceFileName As String, wsArraySheet As String, iZt As String
Public LastRow As Long, cTrValue As Long, cTr4Loop As Long
Public arrValue() As Variant, arrCount() As Variant
Public rngCell As Range

Sub vladimiratanasiu()
    
    Application.ScreenUpdating = False
    
    Set SourceSHT = ActiveSheet
    ActiveSheet.Select
    LastRow = Range("C" & Rows.Count).End(xlUp).Row

'   Loop used to Get Exact number of Merge Area for the array ReDim
    NumberOfMerge = 0
    For Each rngCell In Range("A3:A" & Cells(Rows.Count, "C").End(xlUp).Row)
        If rngCell.Value <> "" Then
             NumberOfMerge = NumberOfMerge + 1
        End If
    Next
    
    'Redim arrMergeValue for Value of Merge Area
    ReDim arrValue(NumberOfMerge)
    'arrCount Used to store Number of Rows per Merge Value
    ReDim arrCount(NumberOfMerge)
    
    foRce = 1
    For Each rngCell In Range("A3:A" & Cells(Rows.Count, "C").End(xlUp).Row)
        If rngCell.Value <> "" Then
            'Get the Value of MergeArea
            arrValue(foRce) = rngCell.MergeArea(1).Value
            'Get the Number of Rows for said Merge Area
            arrCount(foRce) = rngCell.MergeArea.Count
            foRce = foRce + 1
        End If
    Next
 
    '   Used to get the number of Merge Value
    foRce = foRce - 1
    TargetFileName = ActiveWorkbook.Path & "\TARGET.xlsx"
    Set wbTarget = Workbooks.Open(TargetFileName)
    ActiveWindow.WindowState = xlMaximized

    For oNe = 1 To foRce
        For Each wsLoop In wbTarget.Sheets
            If arrValue(oNe) = wsLoop.Name Then
            aIr = 6
            Do While aIr <= LastRow
                cTr = 7
                If IsEmpty(SourceSHT.Range("C" & aIr)) Then
                Else
                    Do While cTr <= LastRow
                        If SourceSHT.Cells(aIr, 3).Value = wsLoop.Cells(cTr, 2).Value Then
                            wsLoop.Range("C" & cTr).Value = SourceSHT.Range("D" & aIr).Value
                            wsLoop.Range("E" & cTr).Value = SourceSHT.Range("E" & aIr).Value
                            wsLoop.Range("G" & cTr).Value = SourceSHT.Range("F" & aIr).Value
                        End If
                        cTr = cTr + 1
                    Loop
                End If
                aIr = aIr + 1
            Loop
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    MsgBox "Processing Completed....", vbInformation + vbOKOnly, ".:: vladimiratanasiu ::."

End Sub